[
  {
    "path": ".gitignore",
    "content": "/blib/\n/.build/\n_build/\ncover_db/\ninc/\nBuild\n!Build/\nBuild.bat\n.last_cover_stats\n/Makefile\n/Makefile.old\n/MANIFEST.bak\n/META.yml\n/META.json\n/MYMETA.*\nnytprof.out\n/pm_to_blib\n*.o\n*.bs\nMath/convergent_series.db\nResearch/\n"
  },
  {
    "path": "Analyzers/char_counter.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Count and list the unique characters within a file.\n\nuse strict;\nuse warnings;\nuse open IO => ':utf8', ':std';\n\nmy $file = shift @ARGV;\n\ndie \"usage: $0 file\\n\" unless -f $file;\n\nmy %hash;\nopen my $fh, '<', $file;\n\nwhile (defined(my $l = getc $fh)) {\n    next if exists $hash{$l};\n    $hash{$l} = ();\n}\nclose $fh;\n\n{\n    local $, = ' ';\n    print '-' x 80 . \"\\n\";\n\n    print my (@list) = (sort { lc $a cmp lc $b } keys %hash);\n\n    print \"\\n\" . '-' x 80 . \"\\n\";\n    print unpack('C*', join('', @list));\n    print \"\\n\" . '-' x 80 . \"\\n\";\n}\n\nprintf \"\\n** Unique characters used: %d\\n\\n\", scalar keys %hash;\n"
  },
  {
    "path": "Analyzers/chr_freq.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 30 March 2012\n# https://github.com/trizen\n\n# Count Character Frequency in a file\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse open IO => ':utf8', ':std';\n\nmy %table;\nmy %memoize;\n\nmy %white_spaces = (\n                    ord(\"\\r\") => q{\\r},\n                    ord(\"\\n\") => q{\\n},\n                    ord(\"\\f\") => q{\\f},\n                    ord(\"\\t\") => q{\\t},\n                    ord(\" \")  => q{' '},\n                   );\n\nmy $file = shift // $0;\n\nopen my $fh, '<', $file or die \"Unable to open $file: $!\";\nwhile (defined(my $char = getc $fh)) {\n    ++$table{\n        $memoize{$char} // do {\n            $memoize{$char} = ord $char;\n          }\n      };\n}\nclose $fh;\n\n$= = 80;\nformat STDOUT_TOP =\nCHR             ORD            USED\n-----------------------------------\n.\n\nmy $key;\n\nformat STDOUT =\n@>>         @>>>>>>         @>>>>>>\n$white_spaces{$key} // chr $key, $key, $table{$key}\n.\n\nforeach $key (sort { $table{$b} <=> $table{$a} } keys %table) {\n    write;\n}\n\nsay \"\\nUnique characters used: \", scalar keys %table;\n"
  },
  {
    "path": "Analyzers/dieharder.pl",
    "content": "#!/usr/bin/perl\n\n#\n## Test Perl's pseudorandom number generator with `dieharder`.\n#\n\n# usage:\n#       perl dieharder.pl > rand.txt && dieharder -g 202 -f rand.txt -a\n\nuse 5.014;\nuse strict;\nuse warnings;\n\nmy $seed  = srand();\nmy $count = 1e6;\nmy $bits  = 32;\n\nprint <<\"EOT\";\n#==================================================================\n# generator lcg  seed = $seed\n#==================================================================\ntype: d\ncount: $count\nnumbit: $bits\nEOT\n\nmy $max = 2**$bits;\n\nfor (1 .. $count) {\n    say int(rand($max));\n}\n"
  },
  {
    "path": "Analyzers/first_letter_top.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 25 June 2016\n# Website: https://github.com/trizen\n\n# Make a top with the first letters of each word in a given text.\n\n# usage: cat file.txt | perl first_letter_top.pl\n\nuse 5.014;\nuse strict;\nuse warnings;\n\nuse List::Util qw(sum);\nuse open IO => ':utf8', ':std';\n\nmy %table;\n\nforeach my $word (split(' ', do { local $/; <> })) {\n    if ($word =~ /^[^\\pL]*(\\pL)/) {\n        $table{lc($1)}++;\n    }\n}\n\nmy $max = sum(values %table);\n\nforeach my $key (sort { $table{$b} <=> $table{$a} } keys %table) {\n    printf(\"%s -> %3d (%5.2f%%)\\n\", $key, $table{$key}, $table{$key} / $max * 100);\n}\n"
  },
  {
    "path": "Analyzers/kcal/kcal.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 13 February 2015\n# Website: https://github.com/trizen\n\n# Analyze a CSV list of products based on their values.\n# (the energy expressed in kcal/100g divided by the price/100g)\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\nuse Text::CSV;\n\nmy $input_file = shift() // 'products.csv';\n\nsub process_products_file {\n    my ($file) = @_;\n\n    my $csv = Text::CSV->new(\n                             {\n                              allow_whitespace => 1,\n                              sep_char         => ',',\n                             }\n                            )\n      or die \"Cannot use CSV: \" . Text::CSV->error_diag();\n\n    open my $fh, '<:encoding(UTF-8)', $file;\n\n    my @columns = map { lc(s/\\W.*//rs) } @{$csv->getline($fh)};\n    $csv->column_names(@columns);\n\n    my @products;\n    while (my $row = $csv->getline_hr($fh)) {\n        push @products, {%{$row}, value => $row->{kcal} / $row->{price}};\n    }\n    return @products;\n}\n\nmy @products = process_products_file($input_file);\nmy @sorted_products = sort { $b->{value} <=> $a->{value} } @products;\n\nforeach my $product (@sorted_products) {\n    printf(\"%-35s%-10g%-10g(%g)\\n\", $product->{name}, $product->{kcal}, $product->{price}, $product->{value});\n}\n"
  },
  {
    "path": "Analyzers/kcal/products.csv",
    "content": "name, kcal/100g, price/100g\nMilk (1.5% fat),44,0.3\nDark chocolate (50% cacao),519,2.7\nMustard,178,0.93\nMountain dew,52,0.54\nSour cream (12% fat),131,0.7\nSour cream (20% fat),207,0.9\nPearl barley,352,0.3\nCorn flour,350,0.2\nPufuleti,427,1.2\nBeer,40,0.37\nChocolate (30% cacao),521,2.45\nYogurt (2.5% fat),51,0.38\nFish eggs,553,1.53\nStrong beer,53,0.4\nEggs,130,0.86\nWheat flakes,304,0.4\nPork meat,541,2.4\nIce cream,226,1.6\n"
  },
  {
    "path": "Analyzers/kernel_config_diff.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 16 March 2013\n# https://github.com/trizen\n\n# List activated options from config_2, which are\n# not activated in config_1, or have different values.\n\n# Will print them in CSV format.\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse Text::CSV qw();\n\n$#ARGV == 1 or die <<\"USAGE\";\nusage: $0 [config_1] [config_2]\nUSAGE\n\nmy ($config_1, $config_2) = @ARGV;\n\nsub parse_option {\n    my ($line) = @_;\n\n    if ($line =~ /^(CONFIG_\\w+)=(.*)$/) {\n        return $1, $2;\n    }\n    elsif ($line =~ /^# (CONFIG_\\w+) is not set$/) {\n        return $1, undef;\n    }\n    elsif ($line =~ /^\\W*CONFIG_\\w/) {\n        die \"ERROR: Can't parse line: $line\\n\";\n    }\n\n    return;\n}\n\nmy %table;\n{\n    open my $fh, '<', $config_1;\n    while (<$fh>) {\n\n        my ($name, $value) = parse_option($_);\n        $name // next;\n\n        $table{$name} = $value;\n    }\n}\n\n{\n    my $csv = Text::CSV->new({binary => 1, eol => \"\\n\"})\n      or die \"Cannot use CSV: \" . Text::CSV->error_diag();\n\n    $csv->print(\\*STDOUT, [\"OPTION NAME\", $config_1, $config_2]);\n\n    open my $fh, '<', $config_2;\n    while (<$fh>) {\n\n        my ($name, $value) = parse_option($_);\n        $name // next;\n\n        if (defined $value) {\n            if (not defined $table{$name}) {\n                $csv->print(\\*STDOUT, [$name, (exists $table{$name} ? \"is not set\" : \"-\"), $value]);\n            }\n            else {\n                if ($table{$name} ne $value) {\n                    $csv->print(\\*STDOUT, [$name, $table{$name}, $value]);\n                }\n            }\n        }\n\n    }\n}\n"
  },
  {
    "path": "Analyzers/perl_code_analyzer.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 04 January 2015\n# Website: https://github.com/trizen\n\n#\n## Analyze your Perl code and see whether you are or not a true Perl hacker!\n#\n\n# More info about this script:\n# https://trizenx.blogspot.com/2015/01/perl-code-analyzer.html\n\nuse utf8;\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse IPC::Open2      qw(open2);\nuse Encode          qw(encode_utf8 decode_utf8);\nuse Getopt::Long    qw(GetOptions);\nuse Algorithm::Diff qw(LCS_length);\nuse Perl::Tokenizer qw(perl_tokens);\n\nmy $strict_level = 1;\nmy %ignored_types;\n\nsub help {\n    my ($code) = @_;\n    print <<\"HELP\";\nusage: $0 [options] [file] [...]\n\noptions:\n    --strict [level]   : sets the strictness level (default: $strict_level)\n\nValid strict levels:\n    >= 1   : ignores strings, PODs, comments, spaces and semicolons\n    >= 2   : ignores round parentheses\n    >= 3   : ignores here-documents, (q|qq|qw|qx) quoted strings\n    >= 4   : ignores hex and binary literal numbers\n\nIf level=0, any stricture will be disabled.\nHELP\n    exit($code // 0);\n}\n\nGetOptions('strict=i' => \\$strict_level,\n           'help|h'   => sub { help(0) },)\n  or die(\"Error in command line arguments\\n\");\n\n@ARGV || help(2);\n\nif ($strict_level >= 1) {\n    @ignored_types{\n        qw(\n          pod\n          data\n          comment\n          vertical_space\n          horizontal_space\n          other_space\n          semicolon\n          double_quoted_string\n          single_quoted_string\n          )\n    } = ();\n}\n\nif ($strict_level >= 2) {\n    @ignored_types{\n        qw(\n          parenthesis_open\n          parenthesis_close\n          )\n    } = ();\n}\n\nif ($strict_level >= 3) {\n    @ignored_types{\n        qw(\n          heredoc\n          heredoc_beg\n          q_string\n          qq_string\n          qw_string\n          qx_string\n          )\n    } = ();\n}\n\nif ($strict_level >= 4) {\n    @ignored_types{\n        qw(\n          hex_number\n          binary_number\n          )\n    } = ();\n}\n\nsub deparse {\n    my ($code) = @_;\n\n    local (*CHLD_IN, *CHLD_OUT);\n    my $pid = open2(\\*CHLD_OUT, \\*CHLD_IN, $^X, '-MO=Deparse', '-T');\n\n    print CHLD_IN encode_utf8($code);\n    close(CHLD_IN);\n\n    my $deparsed = do {\n        local $/;\n        decode_utf8(<CHLD_OUT>);\n    };\n\n    waitpid($pid, 0);\n\n    my $child_exit_status = $? >> 8;\n    if ($child_exit_status != 0) {\n        die \"B::Deparse failed with code: $child_exit_status\\n\";\n    }\n\n    return $deparsed;\n}\n\nsub get_tokens {\n    my ($code) = @_;\n    my @tokens;\n    perl_tokens {\n        my ($token) = @_;\n        if (not exists $ignored_types{$token}) {\n            push @tokens, $token;\n        }\n    }\n    $code;\n    return @tokens;\n}\n\nforeach my $script (@ARGV) {\n\n    print STDERR \"=> Analyzing: $script\\n\";\n\n    my $code = do {\n        open my $fh, '<:utf8', $script;\n        local $/;\n        <$fh>;\n    };\n\n    my $d_code = eval { deparse($code) };\n    $@ && do { warn $@; next };\n\n    my @types   = get_tokens($code);\n    my @d_types = get_tokens($d_code);\n\n    if (@types == 0 or @d_types == 0) {\n        warn \"This script seems to be empty! Skipping...\\n\";\n        next;\n    }\n\n    my $len   = LCS_length(\\@types, \\@d_types) - abs(@types - @d_types);\n    my $score = (100 - ($len / @types * 100));\n\n    if ($score >= 60) {\n        printf(\"WOW!!! We have here a score of %.2f! This is obfuscation, isn't it?\\n\", $score);\n    }\n    elsif ($score >= 40) {\n        printf(\"Outstanding! This code seems to be written by a true legend! Score: %.2f\\n\", $score);\n    }\n    elsif ($score >= 20) {\n        printf(\"Amazing! This code is very unique! Score: %.2f\\n\", $score);\n    }\n    elsif ($score >= 15) {\n        printf(\"Excellent! This code is written by a true Perl hacker. Score: %.2f\\n\", $score);\n    }\n    elsif ($score >= 10) {\n        printf(\"Awesome! This code is written by a Perl expert. Score: %.2f\\n\", $score);\n    }\n    elsif ($score >= 5) {\n        printf(\"Just OK! We have a score of %.2f! This is production code, isn't it?\\n\", $score);\n    }\n    else {\n        printf(\"What is this? I guess it is some baby Perl code, isn't it? Score: %.2f\\n\", $score);\n    }\n}\n"
  },
  {
    "path": "Analyzers/perl_code_spellcheck.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 29 January 2017\n# https://github.com/trizen\n\n# Checks English words for spelling errors in Perl code.\n# It tries to minimize false positives as much as possible.\n\nuse 5.014;\nuse strict;\nuse warnings;\n\nuse Text::Hunspell;\nuse List::Util qw(max);\nuse File::Find qw(find);\nuse Encode qw(decode_utf8);\nuse Perl::Tokenizer qw(perl_tokens);\nuse Text::JaroWinkler qw(strcmp95);\nuse Getopt::Long qw(GetOptions :config no_ignore_case);\n\nbinmode(STDOUT, ':utf8');\n\nmy $similarity     = 90 / 100;\nmy $min_word_len   = 6;\nmy $aggressive     = 0;\nmy $non_word_split = 0;\nmy $scan_cats      = 'com,str';\n\nsub help {\n    my ($code) = @_;\n\n    my $p = sprintf('%.0f', $similarity * 100);\n\n    print <<\"HELP\";\nusage: $0 [options] [files]\n\nOptions:\n        -m  --minimum=f     : minimum length for words (default: $min_word_len)\n        -p  --percentage=f  : minimum similarity percentage (default: $p)\n        -W  --W-split!      : split by non-word characters (default: by space)\n        -s  --scan=s        : categories of tokens to scan (default: \"$scan_cats\")\n\nAll the possible categories for --scan are:\n\n    pod     : scan pod sections (including __END__)\n    str     : scan strings (including here-documents)\n    com     : scan comments\n    var     : scan variable names\n    sub     : scan subroutine declarations\n    bar     : scan barewords (including subroutine/method calls)\n    all     : scan all categories\n\nExample:\n    $0 --scan=pod,com --percentage=75 /my/script.pl\n\nHELP\n\n    exit($code);\n}\n\nmy $percentage;\n\nGetOptions(\n           'm|minimum=i'    => \\$min_word_len,\n           'p|percentage=f' => \\$percentage,\n           's|scan=s'       => \\$scan_cats,\n           'W|W-split!'     => \\$non_word_split,\n           'h|help'         => sub { help(0) },\n          )\n  or die(\"Error in command line arguments\");\n\nmy $scan_pod         = $scan_cats =~ /\\bpod/;\nmy $scan_strings     = $scan_cats =~ /\\bstr/;\nmy $scan_comments    = $scan_cats =~ /\\bcom/;\nmy $scan_variables   = $scan_cats =~ /\\bvar/;\nmy $scan_subroutines = $scan_cats =~ /\\bsub/;\nmy $scan_barewords   = $scan_cats =~ /\\bbar/;\n\nif ($scan_cats =~ /\\ball/) {\n    $scan_pod         = 1;\n    $scan_strings     = 1;\n    $scan_comments    = 1;\n    $scan_variables   = 1;\n    $scan_subroutines = 1;\n    $scan_barewords   = 1;\n}\n\nif (    not $scan_pod\n    and not $scan_strings\n    and not $scan_comments\n    and not $scan_variables\n    and not $scan_subroutines\n    and not $scan_barewords) {\n    die \"Invalid value for `--scan`: <<$scan_cats>>\";\n}\n\nif (defined $percentage) {\n    $similarity = $percentage / 100;\n}\n\n#<<<\nmy $speller = Text::Hunspell->new(\n    \"/usr/share/hunspell/en_US.aff\",\n    \"/usr/share/hunspell/en_US.dic\",\n) or die \"Can't create the speller object: $!\";\n#>>>\n\n@ARGV || help(2);\n\n@ARGV = reverse(@ARGV);\n\nwhile (@ARGV) {\n\n    my %seen;\n    my $file = pop @ARGV;\n\n    if (-d $file) {\n        find {\n            no_chdir => 1,\n            wanted   => sub {\n                if (-f($_) and /\\.p[lm]\\z/) {\n                    push @ARGV, $_;\n                }\n            },\n        } => $file;\n        next;\n    }\n\n    $file = decode_utf8($file);\n\n    open my $fh, '<:encoding(UTF-8)', $file or next;\n    local $SIG{__WARN__} = sub { };\n    my $code = eval { local $/; <$fh> } // next;\n\n    say \"\\n** Scanning: $file\";\n\n    perl_tokens {\n        my ($token, $i, $j) = @_;\n\n        my $string;\n\n        if ($scan_strings) {\n            if ($token eq 'q_string') {\n                $string = substr($code, $i + 2, $j - $i - 3);\n            }\n            elsif (   $token eq 'qq_string'\n                   or $token eq 'qw_string') {\n                $string = substr($code, $i + 3, $j - $i - 4);\n            }\n            elsif (   $token eq 'double_quoted_string'\n                   or $token eq 'single_quoted_string') {\n                $string = substr($code, $i + 1, $j - $i - 2);\n            }\n            elsif ($token eq 'heredoc') {\n                $string = substr($code, $i, $j - $i);\n                $string =~ s/.*\\K\\R.*//s;\n            }\n        }\n\n        if ($scan_comments) {\n            if ($token eq 'comment') {\n                $string = substr($code, $i + 1, $j - $i - 1);\n            }\n        }\n\n        if ($scan_pod) {\n            if (   $token eq 'pod'\n                or $token eq 'data') {\n                $string = substr($code, $i, $j - $i);\n            }\n        }\n\n        if ($scan_variables) {\n            if ($token eq 'var_name') {\n                $string = substr($code, $i, $j - $i);\n            }\n        }\n\n        if ($scan_subroutines) {\n            if ($token eq 'sub_name') {\n                $string = substr($code, $i, $j - $i);\n            }\n        }\n\n        if ($scan_barewords) {\n            if ($token eq 'bare_word') {\n                $string = substr($code, $i, $j - $i);\n            }\n        }\n\n        if (defined $string) {\n            foreach my $word (\n                              $non_word_split\n                              ? split(/[^\\pL]+/, $string)\n                              : split(' ',       $string)\n              ) {\n\n                if (!$non_word_split) {\n                    $word =~ s/^[^\\pL]+//;\n                    $word =~ s/[^\\pL]+\\z//;\n                }\n\n                $word !~ /^[\\pL]+\\z/          and next;\n                length($word) < $min_word_len and next;\n                $seen{$word}++                and next;\n                $speller->check($word)        and next;\n\n                my @suggestions = $speller->suggest($word);\n\n                if (    @suggestions\n                    and lc($suggestions[0]) ne lc($word)\n                    and $suggestions[0] !~ / /) {\n                    my $score = strcmp95($suggestions[0], $word, max(length($suggestions[0]), length($word)));\n\n                    if ($score >= $similarity) {\n                        printf \"[%.2f] %-20s => [%s]\\n\", $score, $word, join(', ', @suggestions);\n                    }\n                }\n            }\n        }\n    } $code;\n}\n"
  },
  {
    "path": "Analyzers/reptop.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 29 November 2011\n# Edit: 03 November 2012\n# https://github.com/trizen\n\n# Find how many times each word exists in a file.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse open IO => ':utf8', ':std';\nuse Getopt::Long qw(GetOptions :config no_ignore_case);\n\nmy $word;         # count for a particular word\nmy $regex;        # split by regex\nmy $lowercase;    # lowercase words\n\nmy $top    = 0;   # top of repeated words\nmy $length = 1;   # mimimum length of a word\n\nsub usage {\n    print <<\"HELP\";\nusage: $0: [options] <file>\n\\nOptions:\n        -B   : deactivate word match boundary (default: on)\n        -L   : lowercase every word (default: off)\n        -w=s : show how many times a word repeats in the list\n        -t=i : show a top list of 'i' words (default: $top)\n        -l=i : minimum length of a valid word (default: $length)\n        -r=s : split by a regular expression (default: \\\\W+)\\n\nHELP\n    exit 0;\n}\n\nusage() unless @ARGV;\n\nmy $no_boundary;\n\nGetOptions(\n           'word|w=s'      => \\$word,\n           'top|t=i'       => \\$top,\n           'regex|r=s'     => \\$regex,\n           'no-boundary|B' => \\$no_boundary,\n           'L|lowercase!'  => \\$lowercase,\n           'length|l=i'    => \\$length,\n           'help|h|usage'  => \\&usage,\n          );\n\nmy $boundary = $no_boundary ? '' : '\\\\b';\n$regex = defined $regex ? qr/$regex/ : qr/\\W+/;\n\nforeach my $file (grep { -f } @ARGV) {\n\n    my $file_content;\n    open my $fh, '<:encoding(UTF-8)', $file or die \"Unable to open file '$file': $!\\n\";\n    read $fh, $file_content, -s $file;\n    close $fh;\n\n    if ($lowercase) {\n        $file_content = lc $file_content;\n    }\n\n    study $file_content;\n\n    if (defined($word)) {\n        my $i = 0;\n        ++$i while $file_content =~ /$boundary\\Q$word\\E$boundary/go;\n        printf \"Word '%s' repeats %d time%s in the list.\\n\", $word, $i, ($i == 1 ? '' : 's');\n        next;\n    }\n\n    my %uniq;\n    @uniq{split($regex, $file_content)} = ();\n\n    my @out;\n    foreach my $word (keys %uniq) {\n        next unless length $word >= $length;\n        my $i = 0;\n        ++$i while $file_content =~ /$boundary\\Q$word\\E$boundary/g;\n        push @out, [$i, $word];\n    }\n\n    my $i      = 0;\n    my @sorted = sort { $b->[0] <=> $a->[0] } @out;\n    my $max    = length $sorted[0][0];\n    print \"> $file\\n\";\n\n    foreach my $out (@sorted) {\n        printf \"%*s -> %s\\n\", $max, $out->[0], $out->[1];\n        last if $top and ++$i == $top;\n    }\n}\n"
  },
  {
    "path": "Analyzers/text_stats.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 15 June 2013\n# https://github.com/trizen\n\n#\n## This script will compare the repetition of words from different authors.\n#\n## Example:\n#       perl text_stats.pl shake_1.txt shake_2.txt - twain_1.txt twain_2.txt\n#\n# The above example compares the files from two authors.\n# If the first author written more words than the second one,\n# the script will estimate the repetition of words from the second author\n# as if it wrote the same amounts of words as the first author.\n#\n# You can provide as many authors as you want, separated by a dash argument (-).\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse open IO => 'utf8';\nuse Text::Unidecode qw(unidecode);\n\nmy @authors = [];\n\nwhile (@ARGV) {\n    my $file = shift @ARGV;\n\n    if ($file eq '-') {\n        push @authors, [];\n        next;\n    }\n\n    -f $file or do { warn \"$0: '$file' is not a file!\\n\"; next };\n\n    push @{$authors[-1]}, $file;\n}\n\nmy %table;\nforeach my $author_files (@authors) {\n    foreach my $file (@{$author_files}) {\n\n        open my $fh, '<', $file;\n\n        while (<$fh>) {\n\n            s{[^\\-'[:^punct:]]+}{ }g;   # try to comment out this line\n            my @words = split(' ', unidecode(lc));\n\n            s{^[[:punct:]]+}{}, s{[[:punct:]]+\\z}{} for @words;\n            /^\\w/ && /\\w\\z/ && $table{$author_files}{$_}++ for @words;\n        }\n    }\n}\n\nmy %data;\nmy @lens;\nforeach my $i (0 .. $#authors) {\n\n    my $author = $authors[$i];\n    my $words  = $table{$author};\n\n    while (my ($word, $cnt) = each %{$words}) {\n        $data{$word} //= [(0) x $i];\n        push @{$data{$word}}, $cnt;\n    }\n\n    push @lens, scalar keys %{$words};\n}\n\nmy @ratios = (1);\nforeach my $i (1 .. $#lens) {\n    push @ratios, $lens[$i] / $lens[$i-1];\n}\n\nprint join(',', \"WORD\", (map { qq[\"AUTHOR $_\"] } 1 .. $#authors + 1)), \"\\n\";\n\nforeach my $key (sort { $data{$b}[0] <=> $data{$a}[0] } keys %data) {\n    my @row;\n    foreach my $i (0 .. $#authors) {\n        push @row, sprintf(\"%0.f\", ($data{$key}[$i] // 0) / $ratios[$i]);\n    }\n    print join(',', qq[\"$key\"], @row), \"\\n\";\n}\n"
  },
  {
    "path": "Analyzers/unidecode_word_top.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 11 March 2013\n# https://github.com/trizen\n\n# usage: perl unidecode_word_top.pl [file]\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\nuse Text::Unidecode qw(unidecode);\n\nopen my $fh, '<:encoding(UTF-8)', shift;\n\nmy %table;\nwhile (<$fh>) {\n    my @words = split(' ', unidecode(lc $_));\n    s{^[[:punct:]]+}{}, s{[[:punct:]]+\\z}{} for @words;\n    /^\\w/ && /\\w\\z/ && $table{$_}++ for @words;\n}\n\nforeach my $key (sort { $table{$b} <=> $table{$a} || $a cmp $b } keys %table) {\n    printf \"%-50s%4s\\n\", $key, $table{$key};\n}\n"
  },
  {
    "path": "Analyzers/wcer.pl",
    "content": "#!/usr/bin/perl\n\n# Count words in a text file\n# Coded by Trizen under GPL.\n# usage: cat file.txt | perl wcer\n#        perl wcer file.txt\n\nmy $x = 0;\nwhile (<>) {$x+=split' '}\nprint STDOUT \"$x\\n\";\nexit 0;\n"
  },
  {
    "path": "Analyzers/word_suffix_top.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 05 April 2015\n# https://github.com/trizen\n\n# Word suffix top\n\nuse 5.014;\nuse autodie;\nuse warnings;\n\nuse Text::Unidecode qw(unidecode);\n\nmy %top;\nmy $file = shift() // die \"usage: $0 file [suffix len]\\n\";\nmy $i    = shift() // 3;\nmy $total = 0;\n\n{\n    open my $fh, '<:utf8', $file;\n    while (<$fh>) {\n        s/[_\\W]+\\z//;\n        if (/(\\w{$i})\\z/) {\n            ++$top{lc(unidecode($1))};\n            ++$total;\n        }\n    }\n    close $fh;\n}\n\nmy $lonely = 0;\nforeach my $key (sort { $top{$b} <=> $top{$a} or $a cmp $b } keys %top) {\n    printf(\"%s%10s%10.02f%%\\n\", $key, $top{$key}, $top{$key} / $total * 100);\n    ++$lonely if ($top{$key} == 1);\n}\n\nprintf \"\\n** Unique suffixes: %.02f%%\\n\", $lonely / $total * 100;\n"
  },
  {
    "path": "Audio/auto-mp3tags.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 15 August 2011\n# Edit: 11 August 2019\n# https://github.com/trizen\n\n# Adds auto-tags to MP3 audio files in a given directory and its subdirectories.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse MP3::Tag;\nuse File::Find qw(find);\nuse File::Copy qw(copy);\nuse File::Temp qw(tempfile);\nuse File::Basename qw(basename);\nuse Encode qw(encode_utf8 decode_utf8);\n\nmy @files = grep { -e $_ } @ARGV;\n\ndie \"Usage: $0 <dirs|files>\\n\" unless @files;\n\nmy @mp3_files;\n\nfind(\\&wanted_files, @files);\n\nsub wanted_files {\n    my $file = $File::Find::name;\n    push @mp3_files, $file if $file =~ /\\.mp3\\z/i;\n}\n\nforeach my $filename (@mp3_files) {\n\n    say \"Processing: $filename\";\n\n    my (undef, $tmpfile) = tempfile(basename($filename) . ' - XXXXXX', TMPDIR => 1);\n\n    unlink($tmpfile);\n    $tmpfile =~ s/ - .{6}\\z//;\n    copy($filename, $tmpfile);\n\n    my $mp3 = 'MP3::Tag'->new($tmpfile);\n\n    my @fields = qw(artist album title comment);\n\n    $mp3->config(write_v24 => 1);\n    $mp3->autoinfo;\n    $mp3->update_tags({map { $_ => decode_utf8($mp3->$_) } @fields});\n    $mp3->close;\n\n    unlink($filename);\n    copy($tmpfile, $filename);\n    unlink($tmpfile);\n}\n"
  },
  {
    "path": "Audio/group_audio_files.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 11 August 2019\n# https://github.com/trizen\n\n# Group MP3 files in directories based on their artist name.\n\n# Example:\n#   Foo - abc.mp3\n#   Foo - xyz.mp3\n\n# Both files will be moved in a new directory named \"Foo\".\n# The directory \"Foo\" is created in the current working directory from which the script is executed.\n\nuse 5.016;\nuse strict;\nuse warnings;\n\nbinmode(STDOUT, ':utf8');\n\nuse Encode qw(decode_utf8);\nuse Text::Unidecode qw(unidecode);\n\nuse File::Find qw(find);\nuse File::Copy qw(move);\nuse File::Basename qw(basename);\nuse File::Spec::Functions qw(catdir catfile curdir);\n\nuse List::Util qw(sum);\nuse List::UtilsBy qw(max_by);\n\nmy $file_formats = qr{\\.(?:mp3|mp4|webm|mkv|opus|ogg|oga)\\z}i;    # file formats\nmy (@files) = grep { -e $_ } @ARGV;\n\nif (not @files) {\n    die \"usage: $0 [dir]\\n\";\n}\n\nmy @audio_files;\n\nfind(\\&wanted_files, @files);\n\nsub wanted_files {\n    my $file = $File::Find::name;\n    push @audio_files, $file if ($file =~ $file_formats);\n}\n\nif (@audio_files) {\n    say \":: Found \", scalar(@audio_files), \" audio files...\";\n}\nelse {\n    say \":: No file found...\";\n}\n\nmy %groups;\n\nforeach my $filename (@audio_files) {\n\n    my $basename = decode_utf8(basename($filename));\n\n    my $artist;\n    if ($basename =~ /^[\\d\\s.\\-–]*(.+?) -/) {\n        $artist = $1;\n    }\n    elsif ($basename =~ /^[\\d\\s.\\-–]*(.+?)-/) {\n        $artist = $1;\n    }\n    else {\n        next;\n    }\n\n    # Remove extra whitespace\n    $artist = join(' ', split(' ', $artist));\n\n    # Unidecode key and remove whitespace\n    my $key = join('', split(' ', unidecode(CORE::fc($artist))));\n\n    $key =~ s/[[:punct:]]+//g;    # remove any punctuation characters\n    $key =~ s/\\d+//g;             # remove any digits\n\n    if ($key eq '' or $artist eq '') {\n        next;\n    }\n\n    push @{$groups{$key}{files}},\n      {\n        filepath => $filename,\n        basename => $basename,\n      };\n\n    ++$groups{$key}{artists}{$artist};\n}\n\nwhile (my ($key, $group) = each %groups) {\n\n    my $files   = $group->{files};\n    my $artists = $group->{artists};\n\n    sum(values %$artists) > 1 or next;    # ignore single files\n\n    my $common_name = max_by { $artists->{$_} } sort { $a cmp $b } keys %$artists;\n\n    foreach my $file (@{$files}) {\n\n        my $group_dir = catdir(curdir(), $common_name);\n\n        if (not -e $group_dir) {\n            mkdir($group_dir) || do {\n                warn \"[!] Can't create directory `$group_dir`: $!\\n\";\n                next;\n            };\n        }\n\n        if (not -d $group_dir) {\n            warn \"[!] Not a directory: $group_dir\\n\";\n            next;\n        }\n\n        my $target = catfile($group_dir, $file->{basename});\n\n        if (not -e $target) {\n            say \"[*] Moving file `$file->{basename}` into `$common_name` directory...\";\n            move($file->{filepath}, $target) || warn \"[!] Failed to move: $!\\n\";\n        }\n    }\n}\n"
  },
  {
    "path": "Audio/mkv_audio_to_opus.pl",
    "content": "#!/usr/bin/perl\n\n# Convert MKV audio files to OPUS files, in a given directory (and its subdirectories).\n\n# Requires `ffmpeg` and `exiftool`.\n\nuse 5.036;\nuse File::Find            qw(find);\nuse File::Temp            qw(mktemp);\nuse File::Copy            qw(move);\nuse File::Basename        qw(dirname basename);\nuse File::Spec::Functions qw(catfile);\nuse Getopt::Long          qw(GetOptions);\n\nmy $bitrate = 96;\n\nsub usage ($exit_code = 0) {\n    print <<\"EOT\";\nusage: $0 [options] [files | directories]\n\noptions:\n    -b --bitrate=i  : output bitrate in kbps (default: $bitrate)\n    -h --help       : display this message and exit\n\nEOT\n    exit($exit_code);\n}\n\nGetOptions('b|bitrate=i' => \\$bitrate,\n           'h|help'      => sub { usage(0) },)\n  or die(\"Error in command line arguments\");\n\nsub is_mkv_audio ($file) {\n    my $res = `exiftool \\Q$file\\E`;\n    $? == 0       or return;\n    defined($res) or return;\n    $res =~ m{^MIME\\s+Type\\s*:\\s*audio/x-matroska}mi;\n}\n\nsub convert ($file) {\n    my $tmpfile = mktemp(\"tempXXXXXXXXXXX\") . '.opus';\n    say \":: Temporary file: $tmpfile\";\n\n    system(\"ffmpeg\", '-loglevel', 'warning', \"-i\", $file, \"-b:a\", $bitrate . \"K\", $tmpfile);\n\n    $? == 0 or do {\n        unlink($tmpfile);\n        return;\n    };\n\n    my $dir      = dirname($file);\n    my $basename = basename($file) =~ s{\\.\\w+\\z}{.opus}r;\n    my $new_file = catfile($dir, $basename);\n\n    unlink($file) or return;\n    say \":: Moving: $tmpfile -> $new_file\";\n    move($tmpfile, $new_file);\n}\n\nmy @dirs = @ARGV;\n\n@dirs || usage(1);\n\nfind(\n    {\n     wanted => sub {\n         if (-f $_ and is_mkv_audio($_)) {\n             say \":: Converting: $_\";\n             convert($_);\n         }\n     },\n    },\n    @dirs\n);\n"
  },
  {
    "path": "Audio/recompress_audio_track.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 06 September 2023\n# https://github.com/trizen\n\n# Make video files smaller, by recompressing the audio track to the OPUS format (40kbps), using ffmpeg.\n\n# Requires the following tools:\n#   ffmpeg\n#   exiftool\n\n# Usage:\n#   perl recompress_audio_track.pl [files | directories]\n\nuse 5.036;\nuse File::Temp            qw(mktemp);\nuse File::Find            qw(find);\nuse File::Copy            qw(move);\nuse File::Basename        qw(dirname basename);\nuse File::Spec::Functions qw(catfile);\n\nsub is_video_file ($file) {\n    my $res = `exiftool \\Q$file\\E`;\n    $? == 0       or return;\n    defined($res) or return;\n    $res =~ m{^MIME\\s+Type\\s*:\\s*video/}mi;\n}\n\nsub recompress_audio_track ($video_file) {\n\n    say \":: Extracting audio track...\";\n    my $orig_audio_file = mktemp(\"tempXXXXXXXXXXX\") . '.mkv';\n    system(\"ffmpeg\", \"-loglevel\", \"warning\", \"-i\", $video_file, \"-vn\", \"-acodec\", \"copy\", $orig_audio_file);\n\n    $? == 0 or do {\n        unlink($orig_audio_file);\n        return;\n    };\n\n    say \":: Recompressing audio track...\";\n    my $new_audio_file = mktemp(\"tempXXXXXXXXXXX\") . '.opus';\n    system(\"ffmpeg\", \"-loglevel\", \"warning\", \"-i\", $orig_audio_file, \"-vn\", \"-sn\", \"-dn\", \"-c:a\", \"libopus\", \"-b:a\", \"40K\", $new_audio_file);\n\n    $? == 0 or do {\n        unlink($new_audio_file);\n        return;\n    };\n\n    # When the original file is smaller, keep the original file\n    if ((-s $orig_audio_file) <= (-s $new_audio_file)) {\n        say \":: The original audio track is smaller... Will keep it...\";\n        unlink($new_audio_file);\n        $new_audio_file = $orig_audio_file;\n    }\n\n    say \":: Merging the recompressed audio track with the video...\";\n    my $new_video_file = mktemp(\"tempXXXXXXXXXXX\") . '.mkv';\n    system(\"ffmpeg\", \"-loglevel\", \"warning\", \"-i\", $video_file, \"-i\", $new_audio_file,\n           \"-map_metadata\", \"0\", \"-map\", \"0:v\", \"-map\", \"1:a\", \"-map\", \"0:s?\", \"-c\", \"copy\", $new_video_file);\n\n    $? == 0 or do {\n        unlink($new_audio_file);\n        unlink($new_video_file);\n        return;\n    };\n\n    my $dir              = dirname($video_file);\n    my $basename         = basename($video_file) =~ s{\\.\\w+\\z}{.mkv}r;\n    my $final_video_file = catfile($dir, $basename);\n\n    if ($final_video_file !~ /\\.mkv\\z/) {\n        $final_video_file .= '.mkv';\n    }\n\n    my $original_size = -s $orig_audio_file;\n    my $new_size      = -s $new_audio_file;\n\n    printf(\":: Saved: %.2f MB (%.2f%%)\\n\", ($original_size - $new_size) / 1024**2, ($original_size - $new_size) / $original_size * 100);\n\n    unlink($video_file);\n    unlink($new_audio_file);\n    unlink($orig_audio_file);\n\n    move($new_video_file, $final_video_file);\n}\n\nmy @dirs = @ARGV;\n\nif (not @dirs) {\n    die \"usage: $0 [files | directories]\\n\";\n}\n\nfind(\n    {\n     wanted => sub {\n         if (-f $_ and is_video_file($_)) {\n             say \"\\n:: Processing: $_\";\n             recompress_audio_track($_);\n         }\n     },\n    },\n    @dirs\n);\n"
  },
  {
    "path": "Audio/rem-mp3tags.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 15 August 2011\n# Edit: 11 August 2019\n# https://github.com/trizen\n\n# Removes tags of MP3 audio files in a given directory and its subdirectories.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse MP3::Tag;\nuse File::Find qw(find);\nuse File::Copy qw(copy);\nuse File::Temp qw(tempfile);\nuse File::Basename qw(basename);\n\nmy (@files) = grep { -e $_ } @ARGV;\n\ndie \"Usage: $0 <dirs|files>\\n\" unless @files;\n\nmy $quiet = scalar grep { /^--?(?:q|quiet)\\z/ } @ARGV;\n\nmy @mp3_files;\n\nfind(\\&wanted_files, @files);\n\nsub wanted_files {\n    my $file = $File::Find::name;\n    push @mp3_files, $file if $file =~ /\\.mp3\\z/i;\n}\n\nforeach my $filename (@mp3_files) {\n\n    my (undef, $tmpfile) = tempfile(basename($filename) . ' - XXXXXX', TMPDIR => 1);\n\n    unlink($tmpfile);\n    $tmpfile =~ s/ - .{6}\\z//;\n    copy($filename, $tmpfile);\n\n    my $mp3 = 'MP3::Tag'->new($tmpfile);\n\n    $mp3->get_tags;\n\n    my $had_tags = 0;\n\n    if (exists $mp3->{'ID3v1'}) {\n        say \"[ID3v1] Removing tag: $filename\" unless $quiet;\n        $mp3->{'ID3v1'}->remove_tag;\n        $had_tags = 1;\n    }\n\n    if (exists $mp3->{'ID3v2'}) {\n        say \"[ID3v2] Removing tag: $filename\" unless $quiet;\n        $mp3->{'ID3v2'}->remove_tag;\n        $had_tags = 1;\n    }\n\n    $mp3->close;\n\n    if ($had_tags) {\n        unlink($filename);\n        copy($tmpfile, $filename);\n    }\n\n    unlink($tmpfile);\n}\n"
  },
  {
    "path": "Audio/wave-cmp.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 22 March 2015\n# Website: https://github.com/trizen\n\n# Find similar audio files by comparing their waveforms.\n\n# Review:\n#   https://trizenx.blogspot.com/2015/03/similar-audio-files.html\n\n#\n## The waveform is processed block by block:\n#  _________________________________________\n# |_____|_____|_____|_____|_____|_____|_____|\n# |_____|_____|_____|_____|_____|_____|_____|\n# |_____|_____|_____|_____|_____|_____|_____|\n# |_____|_____|_____|_____|_____|_____|_____|\n#\n# Each block has a distinct number of white pixels, which are collected\n# inside an array and constitute the unique fingerprint of the waveform.\n#\n# Now, each block value is compared with the corresponding value\n# of another fingerprint. If the difference from all blocks is within\n# the allowed deviation, then the audio files are marked as similar.\n#\n# In the end, the similar files are reported to the standard output.\n\n# Requirements:\n#   - ffmpeg: https://ffmpeg.org/\n#   - wav2png: https://github.com/beschulz/wav2png\n\nuse utf8;\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nrequire GD;\nGD::Image->trueColor(1);\n\nrequire GDBM_File;\nuse List::Util qw(sum);\nuse Getopt::Long qw(GetOptions);\n\nuse File::Find qw(find);\nuse File::Temp qw(tempdir);\nuse File::Path qw(make_path);\nuse File::Spec::Functions qw(catfile catdir);\n\nrequire Digest::MD5;\nmy $ctx = Digest::MD5->new;\n\nmy $pkgname = 'wave-cmp';\nmy $version = 0.01;\n\nmy $deviation = 5;\n\nmy ($width, $height) = (1800, 300);\nmy ($div_x, $div_y)  = (10,   2);\n\nsub help {\n    my ($code) = @_;\n    print <<\"EOT\";\nusage: $0 [options] [dirs|files]\n\n=> Waveform generation\n    -w  --width=i       : width of the waveform (default: $width)\n    -h  --height=i      : height of the waveform (default: $height)\n\n=> Waveform processing\n    -x  --x-div=i       : divisions along the X-axis (default: $div_x)\n    -y  --y-div=i       : divisions along the Y-axis (default: $div_y)\n    -d  --deviation=i   : tolerance deviation value (default: $deviation)\n\n        --help          : print this message and exit\n        --version       : print the version number and exit\n\nexample:\n    $0 --deviation=6 ~/Music\n\nEOT\n    exit($code);\n}\n\nsub version {\n    print \"$pkgname $version\\n\";\n    exit 0;\n}\n\nGetOptions(\n           'w|width=i'     => \\$width,\n           'h|height=i'    => \\$height,\n           'x|x-div=i'     => \\$div_x,\n           'y|y-div=i'     => \\$div_y,\n           'd|deviation=i' => \\$deviation,\n           'help'          => sub { help(0) },\n           'v|version'     => \\&version,\n          )\n  or die(\"Error in command line arguments\");\n\nmy $sq_x = int($width / $div_x);\nmy $sq_y = int($height / $div_y);\n\nmy $limit_x = $width - $sq_x;\nmy $limit_y = int($height / 2) - $sq_y;    # analyze only the first half\n\n# Source: https://en.wikipedia.org/wiki/Audio_file_format#List_of_formats\nmy @audio_formats = qw(\n  3gp\n  act\n  aiff\n  aac\n  amr\n  au\n  awb\n  dct\n  dss\n  flac\n  gsm\n  m4a\n  m4p\n  mp3\n  mpc\n  ogg oga\n  opus\n  ra rm\n  raw\n  sln\n  tta\n  vox\n  wav\n  wma\n  wv\n  webm\n  );\n\nmy $audio_formats_re = do {\n    local $\" = '|';\n    qr/\\.(?:@audio_formats)\\z/i;\n};\n\nmy $home_dir =\n     $ENV{HOME}\n  || $ENV{LOGDIR}\n  || (getpwuid($<))[7]\n  || `echo -n ~`;\n\nmy $xdg_config_home = catdir($home_dir, '.config');\n\nmy $cache_dir = catdir($xdg_config_home, $pkgname);\nmy $cache_db  = catfile($cache_dir, 'fp.db');\n\nif (not -d $cache_dir) {\n    make_path($cache_dir);\n}\n\nmy $tmpdir = tempdir(CLEANUP => 1);\ntie my %db, 'GDBM_File', $cache_db, &GDBM_File::GDBM_WRCREAT, 0640;\n\n#\n#-- execute the ffmpeg and wave2png commands and return the waveform PNG data\n#\nsub generate_waveform {\n    my ($file, $output) = @_;\n\n#<<<\n    # Using sox (currently broken)\n    # return scalar `sox \\Q$file\\E -q --norm -V0 --multi-threaded -t wav --encoding signed-integer - | wav2png -w $width -h $height -f ffffffff -b 00000000 -o /dev/stdout /dev/stdin`;\n#>>>\n\n    my $tmpfile = catfile($tmpdir, $file . '.wav');\n\n    system(\"ffmpeg\", \"-loglevel\", \"quiet\", \"-i\", $file, $tmpfile);\n    $? == 0 or return;\n\n    my $waveform = `wav2png -w $width -h $height -f 000000ff -b ffffff00 -o /dev/stdout \\Q$tmpfile\\E`;\n\n    unlink($tmpfile);\n    return $waveform;\n}\n\n#\n#-- return the md5 hex digest of the content of a file\n#\nsub md5_file {\n    my ($file) = @_;\n    open my $fh, '<:raw', $file;\n    $ctx->addfile($fh);\n    $ctx->hexdigest;\n}\n\n#\n#-- take image data as input and return a fingerprint array ref\n#\nsub generate_fingerprint {\n    my ($image_data) = @_;\n\n    $image_data eq '' and return;\n\n    state %rgb_cache;    # cache the RGB values of pixels\n\n    my @fingerprint;\n    my $image = GD::Image->new($image_data) // return;\n\n    for (my $i = 0 ; $i <= $limit_x ; $i += $sq_x) {\n        for (my $j = 0 ; $j <= $limit_y ; $j += $sq_y) {\n            my $fill = 0;\n\n            foreach my $x ($i .. $i + $sq_x - 1) {\n                foreach my $y ($j .. $j + $sq_y - 1) {\n                    my $index = $image->getPixel($x, $y);\n                    my $rgb   = $rgb_cache{$index} //= [$image->rgb($index)];\n                    $fill++ if $rgb->[0] == 255;    # check only the value of red\n                }\n            }\n\n            push @fingerprint, $fill;\n        }\n    }\n\n    return \\@fingerprint;\n}\n\n#\n#-- fetch or generate the fingerprint for a given audio file\n#\nsub fingerprint {\n    my ($audio_file) = @_;\n\n    state $local_cache = {};\n\n    return $local_cache->{$audio_file}\n      if exists $local_cache->{$audio_file};\n\n    my $md5 = md5_file($audio_file);\n    my $key = \"$width/$height/$div_x/$div_y/$md5\";\n\n    if (not exists $db{$key}) {\n        my $image_data  = generate_waveform($audio_file)    // return;\n        my $fingerprint = generate_fingerprint($image_data) // return;\n        $db{$key} = join(':', @{$fingerprint});\n        return ($local_cache->{$audio_file} = $fingerprint);\n    }\n\n    $local_cache->{$audio_file} //= [split /:/, $db{$key}];\n}\n\n#\n#-- compare two fingerprints and return true if they are alike\n#\nsub alike_fingerprints {\n    my ($a1, $a2) = @_;\n\n    foreach my $i (0 .. $#{$a1}) {\n        my $value = abs($a1->[$i] - $a2->[$i]) / ($sq_x * $sq_y) * 100;\n        return if $value > $deviation;\n    }\n\n    return 1;\n}\n\n#\n#-- compare two audio files and return true if they are alike\n#\nsub alike_files {\n    my ($file1, $file2) = @_;\n\n    my $fp1 = fingerprint($file1) // return;\n    my $fp2 = fingerprint($file2) // return;\n\n    alike_fingerprints($fp1, $fp2);\n}\n\n#\n#-- find and call $code with a group of similar audio files\n#\nsub find_similar_audio_files {\n    my $code = shift;\n\n    my @files;\n    find {\n        no_chdir => 1,\n        wanted   => sub {\n            /$audio_formats_re/ || return;\n            lstat;\n            (-f _) && (not -l _) && push @files, $_;\n        }\n    } => @_;\n\n    my %groups;\n    my %seen;\n\n    my $limit = $#files;\n\n    foreach my $i (0 .. $limit) {\n        foreach my $j ($i + 1 .. $limit) {\n            next if $seen{$files[$j]};\n            if (alike_files($files[$i], $files[$j])) {\n                $groups{$i} //= [$files[$i]];\n                $seen{$files[$j]}++;\n                push @{$groups{$i}}, $files[$j];\n            }\n        }\n\n        if (exists $groups{$i}) {\n            $code->(delete $groups{$i});\n        }\n    }\n}\n\n#\n#-- print a group of files followed by an horizontal line\n#\nsub print_group {\n    my ($group) = @_;\n\n    foreach my $file (sort { (lc($a) cmp lc($b)) || ($a cmp $b) } @{$group}) {\n        say $file;\n    }\n\n    say \"-\" x 80;\n}\n\n@ARGV || help(2);\nfind_similar_audio_files(\\&print_group, @ARGV);\n"
  },
  {
    "path": "Audio/wave-cmp2.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 22 March 2015\n# Edit: 04 September 2015\n# Website: https://github.com/trizen\n\n# Find similar audio files by comparing their waveforms.\n\n# Review:\n#   https://trizenx.blogspot.com/2015/03/similar-audio-files.html\n\n# Requirements:\n#   - ffmpeg: https://ffmpeg.org\n#   - wav2png: https://github.com/beschulz/wav2png\n\nuse utf8;\nuse 5.022;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse experimental 'bitwise';\n\nrequire GD;\nGD::Image->trueColor(1);\n\nrequire GDBM_File;\nuse List::Util qw(sum);\nuse Getopt::Long qw(GetOptions);\n\nuse File::Find qw(find);\nuse File::Temp qw(tempdir);\nuse File::Path qw(make_path);\nuse File::Spec::Functions qw(catfile catdir);\n\nrequire Digest::MD5;\nmy $ctx = Digest::MD5->new;\n\nmy $pkgname = 'wave-cmp2';\nmy $version = 0.02;\n\n# Mark files as similar based on this percentage\nmy $percentage = 75;\n\n# The size of the waveform\nmy ($width, $height) = (1800, 300);\n\nsub help {\n    my ($code) = @_;\n    print <<\"EOT\";\nusage: $0 [options] [dirs|files]\n\n=> Waveform generation\n    -w  --width=i       : width of the waveform (default: $width)\n    -h  --height=i      : height of the waveform (default: $height)\n\n=> Waveform processing\n    -p  --percentage=i  : minimum percentage of similarity (default: $percentage)\n\n        --help          : print this message and exit\n        --version       : print the version number and exit\n\nexample:\n    $0 --percentage=80 ~/Music\n\nEOT\n    exit($code);\n}\n\nsub version {\n    print \"$pkgname $version\\n\";\n    exit 0;\n}\n\nGetOptions(\n           'w|width=i'      => \\$width,\n           'h|height=i'     => \\$height,\n           'p|percentage=i' => \\$percentage,\n           'help'           => sub { help(0) },\n           'v|version'      => \\&version,\n          )\n  or die(\"Error in command line arguments\");\n\nmy $size = $width * $height;\n\n# Source: https://en.wikipedia.org/wiki/Audio_file_format#List_of_formats\nmy @audio_formats = qw(\n  3gp\n  act\n  aiff\n  aac\n  amr\n  au\n  awb\n  dct\n  dss\n  flac\n  gsm\n  m4a\n  m4p\n  mp3\n  mpc\n  ogg oga\n  opus\n  ra rm\n  raw\n  sln\n  tta\n  vox\n  wav\n  wma\n  wv\n  webm\n  );\n\nmy $audio_formats_re = do {\n    local $\" = '|';\n    qr/\\.(?:@audio_formats)\\z/i;\n};\n\nmy $home_dir =\n     $ENV{HOME}\n  || $ENV{LOGDIR}\n  || (getpwuid($<))[7]\n  || `echo -n ~`;\n\nmy $xdg_config_home = catdir($home_dir, '.config');\n\nmy $cache_dir = catdir($xdg_config_home, $pkgname);\nmy $cache_db  = catfile($cache_dir, 'fp.db');\n\nif (not -d $cache_dir) {\n    make_path($cache_dir);\n}\n\nmy $tmpdir = tempdir(CLEANUP => 1);\ntie my %db, 'GDBM_File', $cache_db, &GDBM_File::GDBM_WRCREAT, 0640;\n\n#\n#-- execute the ffmpeg and wave2png commands and return the waveform PNG data\n#\nsub generate_waveform {\n    my ($file, $output) = @_;\n\n#<<<\n    # Using sox (currently broken)\n    # return scalar `sox \\Q$file\\E -q --norm -V0 --multi-threaded -t wav --encoding signed-integer - | wav2png -w $width -h $height -f ffffffff -b 00000000 -o /dev/stdout /dev/stdin`;\n#>>>\n\n    my $tmpfile = catfile($tmpdir, $file . '.wav');\n\n    system(\"ffmpeg\", \"-loglevel\", \"quiet\", \"-i\", $file, $tmpfile);\n    $? == 0 or return;\n\n    my $waveform = `wav2png -w $width -h $height -f 000000ff -b ffffff00 -o /dev/stdout \\Q$tmpfile\\E`;\n\n    unlink($tmpfile);\n    return $waveform;\n}\n\n#\n#-- return the md5 hex digest of the content of a file\n#\nsub md5_file {\n    my ($file) = @_;\n    open my $fh, '<:raw', $file;\n    $ctx->addfile($fh);\n    $ctx->hexdigest;\n}\n\n#<<<\n#\n#-- compare two fingerprints and return the similarity percentage\n#\nsub alike_percentage {\n    ((($_[0] ^. $_[1]) =~ tr/\\0//) / $size)**2 * 100;\n}\n#>>>\n\n#\n#-- compute the average value of a pixel\n#\nsub avg {\n    ($_[0] + $_[1] + $_[2]) / 3;\n}\n\n#\n#-- take image data as input and return the fingerprint as string\n#\nsub generate_fingerprint {\n    my ($image_data) = @_;\n\n    $image_data eq '' and return;\n\n    my $img = GD::Image->new($image_data) // return;\n\n    my @averages;\n    foreach my $y (0 .. $height - 1) {\n        foreach my $x (0 .. $width - 1) {\n            push @averages, avg($img->rgb($img->getPixel($x, $y)));\n        }\n    }\n\n    my $avg = sum(@averages) / @averages;\n    join('', map { $_ < $avg ? 1 : 0 } @averages);\n}\n\n#\n#-- fetch or generate the fingerprint for a given audio file\n#\nsub fingerprint {\n    my ($audio_file) = @_;\n\n    state $local_cache = {};\n\n    return $local_cache->{$audio_file}\n      if exists $local_cache->{$audio_file};\n\n    my $md5 = md5_file($audio_file);\n    my $key = \"$width/$height/$md5\";\n\n    if (not exists $db{$key}) {\n        my $image_data  = generate_waveform($audio_file)    // return;\n        my $fingerprint = generate_fingerprint($image_data) // return;\n        $db{$key} = pack('B*', $fingerprint);\n        return ($local_cache->{$audio_file} = $fingerprint);\n    }\n\n    $local_cache->{$audio_file} //= unpack('B*', $db{$key});\n}\n\n#\n#-- find and call $code with a group of similar audio files\n#\nsub find_similar_audio_files(&@) {\n    my $callback = shift;\n\n    my @files;\n    find {\n        no_chdir => 1,\n        wanted   => sub {\n            (/$audio_formats_re/o && -f) || return;\n\n            push @files,\n              {\n                fingerprint => fingerprint($_) // return,\n                filename    => $_,\n              };\n        }\n    } => @_;\n\n    #\n    ## Populate the %alike hash\n    #\n    my %alike;\n    foreach my $i (0 .. $#files - 1) {\n        for (my $j = $i + 1 ; $j <= $#files ; $j++) {\n            my $p = alike_percentage($files[$i]{fingerprint}, $files[$j]{fingerprint});\n            if ($p >= $percentage) {\n                $alike{$files[$i]{filename}}{$files[$j]{filename}} = $p;\n                $alike{$files[$j]{filename}}{$files[$i]{filename}} = $p;\n            }\n        }\n    }\n\n    #\n    ## Group the files\n    #\n    my @alike;\n    foreach my $root (\n        map  { $_->[0] }\n        sort { ($a->[1] <=> $b->[1]) || ($b->[2] <=> $a->[2]) }\n        map {\n            my $keys = keys(%{$alike{$_}});\n            my $avg  = sum(values(%{$alike{$_}})) / $keys;\n\n            [$_, $keys, $avg]\n        }\n        keys %alike\n      ) {\n        my @group = keys(%{$alike{$root}});\n        if (@group) {\n            my $avg = 0;\n            $avg += delete($alike{$_}{$root}) for @group;\n            push @alike, {score => $avg / @group, files => [$root, @group]};\n\n        }\n    }\n\n    #\n    ## Callback each group\n    #\n    my %seen;\n    foreach my $group (sort { $b->{score} <=> $a->{score} } @alike) {\n        (@{$group->{files}} == grep { $seen{$_}++ } @{$group->{files}}) and next;\n        $callback->($group->{score}, $group->{files});\n    }\n\n    return 1;\n}\n\n@ARGV || help(2);\nfind_similar_audio_files {\n    my ($score, $files) = @_;\n    printf(\"=> Similarity: %.0f%%\\n\", $score), say join(\"\\n\", @{$files});\n    say \"-\" x 80;\n}\n@ARGV;\n"
  },
  {
    "path": "Benchmarks/array_range_vs_shift.pl",
    "content": "#!/usr/bin/perl\n\nuse 5.014;\n\nuse Benchmark qw(cmpthese);\n\npackage Foo {\n\n    sub new {\n        bless {}, __PACKAGE__;\n    }\n\n    sub call_me { }\n\n    sub bar {\n        $_[0]->call_me(@_[1 .. $#_]);\n    }\n\n    sub baz {\n        shift(@_)->call_me(@_);\n    }\n}\n\nmy $obj = Foo->new();\n\ncmpthese(\n    -1,\n    {\n     with_shift => sub {\n         $obj->baz(1, 2, 3, 4, 5);\n         $obj->baz();\n         $obj->baz(1);\n         $obj->baz(1, 2);\n     },\n     with_range => sub {\n         $obj->bar(1, 2, 3, 4, 5);\n         $obj->bar();\n         $obj->bar(1);\n         $obj->bar(1, 2);\n     },\n    }\n);\n\n__END__\n                Rate with_range with_shift\nwith_range  721308/s         --       -33%\nwith_shift 1071850/s        49%         --\n"
  },
  {
    "path": "Benchmarks/compression_algorithms.pl",
    "content": "#!/usr/bin/perl\n\n# Rough performance comparison of some compression modules on a given file given as an argument.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Time::HiRes qw(gettimeofday tv_interval);\n\nmy $data_str = do {\n    open(my $fh, '<:raw', $ARGV[0] // $0)\n      or die \"Can't open file <<$ARGV[0]>> for reading: $!\";\n    local $/;\n    <$fh>;\n};\n\nsay \"Raw : \", length($data_str);\nsay '';\n\neval {\n    my $t0 = [gettimeofday];\n    require IO::Compress::Gzip;\n    IO::Compress::Gzip::gzip(\\$data_str, \\my $data_gzip);\n\n    say \"Gzip: \", length($data_gzip);\n    say \"Time: \", tv_interval($t0, [gettimeofday]);\n    say '';\n};\n\neval {\n    my $t0 = [gettimeofday];\n    require IO::Compress::Bzip2;\n    IO::Compress::Bzip2::bzip2(\\$data_str, \\my $data_bzip2);\n\n    say \"Bzip: \", length($data_bzip2);\n    say \"Time: \", tv_interval($t0, [gettimeofday]);\n    say '';\n};\n\neval {\n    my $t0 = [gettimeofday];\n    require IO::Compress::RawDeflate;\n    IO::Compress::RawDeflate::rawdeflate(\\$data_str, \\my $data_raw_deflate);\n\n    say \"RDef: \", length($data_raw_deflate);\n    say \"Time: \", tv_interval($t0, [gettimeofday]);\n    say '';\n};\n\neval {\n    my $t0 = [gettimeofday];\n    require IO::Compress::Deflate;\n    IO::Compress::Deflate::deflate(\\$data_str, \\my $data_deflate);\n\n    say \"Defl: \", length($data_deflate);\n    say \"Time: \", tv_interval($t0, [gettimeofday]);\n    say '';\n};\n\neval {\n    my $t0 = [gettimeofday];\n    require IO::Compress::Zip;\n    IO::Compress::Zip::zip(\\$data_str, \\my $data_zip);\n\n    say \"Zip : \", length($data_zip);\n    say \"Time: \", tv_interval($t0, [gettimeofday]);\n    say '';\n};\n\neval {\n    my $t0 = [gettimeofday];\n    require IO::Compress::Lzf;\n    IO::Compress::Lzf::lzf(\\$data_str, \\my $data_lzf);\n\n    say \"Lzf : \", length($data_lzf);\n    say \"Time: \", tv_interval($t0, [gettimeofday]);\n    say '';\n};\n\neval {\n    my $t0 = [gettimeofday];\n    require IO::Compress::Lzip;\n    IO::Compress::Lzip::lzip(\\$data_str, \\my $data_lzip);\n\n    say \"Lzip: \", length($data_lzip);\n    say \"Time: \", tv_interval($t0, [gettimeofday]);\n    say '';\n};\n\neval {\n    my $t0 = [gettimeofday];\n    require IO::Compress::Lzop;\n    IO::Compress::Lzop::lzop(\\$data_str, \\my $data_lzop);\n\n    say \"Lzop: \", length($data_lzop);\n    say \"Time: \", tv_interval($t0, [gettimeofday]);\n    say '';\n};\n\neval {\n    my $t0 = [gettimeofday];\n    require IO::Compress::Zstd;\n    IO::Compress::Zstd::zstd(\\$data_str, \\my $data_zstd);\n\n    say \"Zstd: \", length($data_zstd);\n    say \"Time: \", tv_interval($t0, [gettimeofday]);\n    say '';\n};\n\n0 && eval {\n    my $t0 = [gettimeofday];\n    require IO::Compress::Brotli;\n    my $data_bro = IO::Compress::Brotli::bro($data_str);\n\n    say \"Brot: \", length($data_bro);\n    say \"Time: \", tv_interval($t0, [gettimeofday]);\n    say '';\n};\n"
  },
  {
    "path": "Benchmarks/json_vs_storable.pl",
    "content": "#!/usr/bin/perl\n\n# Speed comparison of JSON::XS vs Storable.\n\n# Result:\n#   Storable is significantly faster for both encoding and decoding of data.\n\nuse 5.014;\nuse strict;\nuse warnings;\n\nuse Storable qw(freeze thaw);\nuse JSON::XS qw(encode_json decode_json);\n\nuse LWP::Simple qw(get);\nuse Benchmark qw(cmpthese);\n\nmy $info = {\n    content     => get(\"https://github.com/\"),\n    description => \"GitHub is where people build software. More than 73 million people use GitHub to discover, fork, and contribute to over 200 million projects.\",\n    id       => \"2df61d3f\",\n    keywords => undef,\n    score    => 2,\n    title    => \"This is a test\",\n    url      => \"https://github.com/\",\n};\n\nmy $storable = freeze($info);\nmy $json     = encode_json($info);\n\nsay \"# Decoding speed:\\n\";\n\ncmpthese(\n    -1,\n    {\n     json => sub {\n         my $data = decode_json($json);\n     },\n     storable => sub {\n         my $data = thaw($storable);\n     },\n    }\n);\n\nsay \"\\n# Encoding speed:\\n\";\n\ncmpthese(\n    -1,\n    {\n     json => sub {\n         my $data = encode_json($info);\n     },\n     storable => sub {\n         my $data = freeze($info);\n     },\n    }\n);\n\n__END__\n\n# Decoding speed:\n\n            Rate     json storable\njson      2327/s       --     -94%\nstorable 41533/s    1685%       --\n\n# Encoding speed:\n\n            Rate     json storable\njson      1541/s       --     -93%\nstorable 21721/s    1309%       --\n"
  },
  {
    "path": "Benchmarks/schwartzian_transform.pl",
    "content": "#!/usr/bin/perl\n\n# Performance comparison of Schwartzian transform.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Schwartzian_transform\n\nuse 5.010;\nuse Benchmark qw(cmpthese);\n\nmy @alpha = map { chr($_) } 32 .. 127;\nmy @arr = (\n    map {\n        join('', map { $alpha[rand @alpha] } 1 .. 140)\n      } 1 .. 100\n);\n\ncmpthese(\n    -1,\n    {\n     schwartz => sub {\n         my @sorted = map { $_->[1] }\n           sort { $a->[0] cmp $b->[0] }\n           map { [lc($_), $_] } @arr;\n         @sorted;\n     },\n     without_schwartz => sub {\n         my @sorted = sort { lc($a) cmp lc($b) } @arr;\n         @sorted;\n     },\n    }\n);\n\n__END__\n                   Rate without_schwartz         schwartz\nwithout_schwartz 4403/s               --             -53%\nschwartz         9309/s             111%               --\n"
  },
  {
    "path": "Benchmarks/types_of_variables.pl",
    "content": "#!/usr/bin/perl\n\n# Performance comparison between `state`, `my` and global variables.\n\nuse 5.010;\nuse Benchmark qw(cmpthese);\n\ncmpthese(\n    -1,\n    {\n     my => sub {\n         my $x = rand(1);\n         $x + 1;\n     },\n     state => sub {\n         state $x;\n         $x = rand(1);\n         $x + 1;\n     },\n     global => sub {\n         $main::global = rand(1);\n         $main::global + 1;\n     }\n    }\n);\n\n\n__END__\n             Rate     my global  state\nmy     12105605/s     --   -17%   -44%\nglobal 14563555/s    20%     --   -32%\nstate  21462081/s    77%    47%     --\n"
  },
  {
    "path": "Book tools/rosettacode_to_markdown.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 24 April 2015\n# Edit: 09 December 2023\n# Website: https://github.com/trizen\n\n# Extract markdown code from each task for a given programming language.\n\nuse utf8;\nuse 5.020;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Text::Tabs             qw(expand);\nuse Encode                 qw(decode_utf8);\nuse Getopt::Long           qw(GetOptions);\nuse File::Path             qw(make_path);\nuse LWP::UserAgent::Cached qw();\nuse URI::Escape            qw(uri_unescape uri_escape);\nuse HTML::Entities         qw(decode_entities);\nuse File::Spec::Functions  qw(catfile catdir);\n\nbinmode(STDOUT, ':utf8');\nbinmode(STDERR, ':utf8');\n\nsub escape_markdown ($t) {\n    $t =~ s{([*_`])}{\\\\$1}g;\n    return $t;\n}\n\nsub escape_lang ($s) {\n    $s =~ s/\\s/_/gr;    # replace whitespace with underscores\n}\n\nsub _ulist ($s) {\n    $s =~ s{<li>(.*?)</li>}{* $1\\n}gsr;\n}\n\nsub _olist ($s) {\n    my $i = 1;\n    $s =~ s{<li>(.*?)</li>}{$i++ . '. ' . \"$1\\n\"}egsr;\n}\n\nsub tags_to_markdown ($t, $escape = 0) {\n\n    my $out = '';\n    until ($t =~ /\\G\\z/gc) {\n        if ($t =~ m{\\G<br\\h*/\\h*>}gc) {\n            $out .= \"\\n\";\n        }\n        elsif ($t =~ m{\\G<b>(.*?)</b>}gcs) {\n            $out .= \"**\" . tags_to_markdown($1, 1) . \"**\";\n        }\n        elsif ($t =~ m{\\G<i>(.*?)</i>}gcs) {\n            $out .= \"*\" . tags_to_markdown($1, 1) . \"*\";\n        }\n        elsif ($t =~ m{\\G<code>(.*?)</code>}gcs) {\n            $out .= \"`\" . decode_entities($1) . \"`\";\n        }\n        elsif ($t =~ m{\\G<tt>(.*?)</tt>}gcs) {\n            $out .= \"`\" . decode_entities($1) . \"`\";\n        }\n        elsif ($t =~ m{\\G<a\\b.*? href=\"(.*?)\".*?>(.*?)</a>}gcs) {\n            my ($url, $label) = ($1, $2);\n\n            if ($url =~ m{^/}) {\n                $url = 'https://rosettacode.org' . $url;\n            }\n\n            $label = tags_to_markdown($label);\n            $out .= \"[$label]($url)\";\n        }\n        elsif ($t =~ m{\\G(<img\\b.*? src=\"/mw/.*?\".*?/>)}gc) {\n            my $html = $1;\n            $html =~ s{ src=\"\\K/mw/}{https://rosettacode.org/mw/};\n            $html =~ s{ srcset=\".*?\"}{};\n            $out .= $html;\n        }\n        elsif ($t =~ m{\\G<span><span class=\"mwe-math-mathml-inline mwe-math-mathml-a11y\"}gc) {\n            $t =~ m{\\G.*?</span>}gsc;\n            if ($t =~ m{\\G<meta class=\"mwe-math-fallback-image-inline\".*? url\\(&#39;(/mw/index\\.php\\?(?:.*?))&#39;\\).*?/></span>}gc) {\n                $out .= '![image](https://rosettacode.org' . decode_entities($1) . ')';\n            }\n            else {\n                warn \"[!] Failed to parse math meta class!\\n\";\n            }\n        }\n        elsif ($t =~ m{\\G<ul>(.*?)</ul>}gcs) {\n            $out .= _ulist(tags_to_markdown($1, 1));\n        }\n        elsif ($t =~ m{\\G<ol>(.*?)</ol>}gcs) {\n            $out .= _olist(tags_to_markdown($1, 1));\n        }\n        elsif ($t =~ /\\G([^<]+)/gc) {\n            $out .= $escape ? escape_markdown($1) : $1;\n        }\n        elsif ($t =~ /\\G(.)/gcs) {\n            $out .= $escape ? escape_markdown($1) : $1;\n        }\n    }\n\n    return $out;\n}\n\nsub strip_tags ($s) {\n    $s =~ s/<.*?>//gsr;    # remove HTML tags\n}\n\nsub strip_space ($s) {\n    unpack('A*', $s =~ s/^\\s+//r);    # remove leading and trailing whitespace\n}\n\nsub extract_tasks ($content, $lang) {\n\n    my $i = index($content, qq{<h2>Pages in category \"$lang\"</h2>});\n\n    if ($i == -1) {\n        warn \"[!] Can't find any tasks for language: <$lang>!\\n\";\n        return;\n    }\n\n    my $tasks_content = substr($content, $i);\n\n    my @tasks;\n    while ($tasks_content =~ m{<a href=\"/wiki/(.+?)\" title=\".+?\">(.+?)</a></li>}g) {\n        my ($task, $label) = ($1, $2);\n\n        last if $task eq 'Special:Categories';\n\n        push @tasks,\n          {\n            name  => decode_utf8(uri_unescape($task)),\n            title => $label,\n          };\n    }\n\n    return \\@tasks;\n}\n\nsub extract_all_tasks ($main_url, $path_url, $lang) {\n\n    my $lwp_uc = LWP::UserAgent->new(\n                                     show_progress => 1,\n                                     agent         => '',\n                                     timeout       => 60,\n                                    );\n\n    my $tasks_url = $main_url . $path_url;\n    my $resp      = $lwp_uc->get($tasks_url);\n    $resp->is_success || die $resp->status_line;\n\n    my $content = $resp->decoded_content;\n    my $tasks   = extract_tasks($content, $lang);\n\n    my @all_tasks = @$tasks;\n\n    if ($content =~ m{<a href=\"([^\"]+)\" title=\"[^\"]+\">next page</a>}) {\n        push @all_tasks, __SUB__->($main_url, $1, $lang);\n    }\n\n    return @all_tasks;\n}\n\nsub extract_lang ($content, $lang, $lang_alias = $lang) {\n\n    my $header = sub {\n        qq{<span class=\"mw-headline\" id=\"$_[0]\">};\n    };\n\n    my $i = index($content, $header->($lang));\n\n    # Try with the language escaped\n    if ($i == -1) {\n        $i = index($content, $header->(escape_lang($lang)));\n    }\n\n    # Try with the language alias\n    if ($i == -1) {\n        $i = index($content, $header->($lang_alias));\n    }\n\n    # Try with the language alias escaped\n    if ($i == -1) {\n        $i = index($content, $header->(escape_lang($lang_alias)));\n    }\n\n    # Give up\n    if ($i == -1) {\n        warn \"[!] Can't find language: <$lang>\\n\";\n        return;\n    }\n\n    my $j = index($content, '<h2>', $i);\n\n    if ($j == -1) {\n        $j = index($content, '<div class=\"printfooter\">', $i);\n    }\n\n    if ($j == -1) {\n        state $x = 0;\n        if (++$x <= 3) {\n            warn \"[!] Position `j` will point at the end of the page...\\n\";\n        }\n        $j = length($content);\n    }\n\n    $i = index($content, '</h2>', $i);\n\n    if ($i == -1) {\n        warn \"[!] Can't find the end of the header!\\n\";\n        return;\n    }\n\n    $i += 5;    # past the end of the header\n\n    my $part = strip_space(substr($content, $i, $j - $i));\n\n    # remove <script> tags\n    $part =~ s{<script\\b.+?</script>}{}gsi;\n\n    # replace [email protected] with 'email@example.net'\n    $part =~ s{<a class=\"__cf_email__\".+?</a>}{email\\@example.net}gsi;\n\n    my @data;\n    until ($part =~ /\\G\\z/gc) {\n        if ($part =~ m{\\G<pre class=\"(.+?) highlighted_source\">(.+)</pre>}gc) {    # old way\n            push @data,\n              {\n                code => {\n                         lang => $1,\n                         data => $2,\n                        }\n              };\n        }\n        elsif ($part =~ m{\\G<div class=\"[^\"]*mw-highlight-lang-(\\S+)[^\"]*\" dir=\"ltr\"><pre>(.*?)</pre>}sgc) {    # new way\n            push @data,\n              {\n                code => {\n                         lang => $1,\n                         data => $2,\n                        }\n              };\n        }\n        elsif ($part =~ m{\\G<h([1-4])>(.*?)</h[1-4]>}sgc) {\n            push @data,\n              {\n                header => {\n                           n    => $1,\n                           data => $2,\n                          }\n              };\n        }\n        elsif ($part =~ m{\\G<p>(.*?)</p>}sgc) {\n            push @data,\n              {\n                text => {\n                         tag  => 'p',\n                         data => $1,\n                        },\n              };\n        }\n        elsif ($part =~ m{\\G<pre\\b[^>]*>(.*?)</pre>}sgc) {\n            push @data,\n              {\n                text => {\n                         tag  => 'pre',\n                         data => $1,\n                        }\n              };\n        }\n        elsif ($part =~ m{\\G(.)}sgc) {\n            @data && exists($data[-1]{unknown})\n              ? ($data[-1]{unknown}{data} .= $1)\n              : (push @data, {unknown => {data => $1}});\n        }\n    }\n\n    return \\@data;\n}\n\nsub to_html ($lang_data) {\n\n    my $text = '';\n    foreach my $item (@{$lang_data}) {\n        if (exists $item->{text}) {\n            $text .= qq{<$item->{text}{tag}>$item->{text}{data}</$item->{text}{tag}>};\n        }\n        elsif (exists $item->{code}) {\n            $text .= qq{<pre class=\"lang $item->{code}{lang}\">$item->{code}{data}</pre>};\n        }\n    }\n\n    return $text;\n}\n\nsub to_markdown ($lang_data) {\n\n    my $text       = '';\n    my $has_output = 1;\n\n    foreach my $item (@{$lang_data}) {\n\n        if (exists $item->{header}) {\n\n            my $n    = $item->{header}{n};\n            my $data = $item->{header}{data};\n\n            my $t = strip_tags(tags_to_markdown(strip_space($data), 1));\n            $t =~ s/\\[\\[edit\\].*//s;\n            $text .= \"\\n\\n\" . ('#' x $n) . ' ' . $t . \"\\n\\n\";\n        }\n        elsif (exists $item->{text}) {\n\n            my $data = $item->{text}{data};\n            my $tag  = $item->{text}{tag};\n\n            if ($tag eq 'p') {\n                my $t = tags_to_markdown(strip_space($data), 1);\n                $text .= \"\\n\\n\" . $t . \"\\n\\n\";\n                $has_output = 1;\n            }\n            elsif ($tag eq 'pre') {\n                my $t = decode_entities($data);\n                $t =~ s/^(?:\\R)+//;\n                $t =~ s/(?:\\R)+\\z//;\n                $t = join(\"\\n\", expand(split(/\\R/, $t)));\n                $text .= \"\\n#### Output:\" if !$has_output;\n                $text .= \"\\n```\\n$t\\n```\\n\";\n            }\n        }\n        elsif (exists $item->{code}) {\n            my $code = decode_entities(strip_tags(tags_to_markdown($item->{code}{data})));\n            my $lang = $item->{code}{lang};\n            $code =~ s/\\[(\\w+)\\]\\(https?:.*?\\)/$1/g;\n            $code =~ s{(?:\\R)+\\z}{};\n            $text .= \"```$lang\\n$code\\n```\\n\";\n            $has_output = 0;\n        }\n    }\n\n    return strip_space($text);\n}\n\nsub write_to_file ($base_dir, $name, $markdown, $overwrite = 0) {\n\n    # Remove parenthesis\n    $name =~ tr/()//d;\n\n    # Substitute bad characters\n    #$name =~ tr{-A-Za-z0-9[]'*_/À-ÿ}{_}c;\n    $name =~ s{[^\\pL\\pN\\[\\]'*/\\-]+}{ }g;\n\n    # Replace multiple spaces with a single underscore\n    $name = join('_', split(' ', $name));\n\n    my $char = uc(substr($name, 0, 1));\n    my $dir  = catdir($base_dir, $char);\n\n    # Remove directory paths from name (if any)\n    if ($name =~ s{^(.*)/}{}) {\n        my $dirname = $1;\n        $dir = catdir($dir, map { $_ eq 'Sorting_Algorithms' ? 'Sorting_algorithms' : $_ } split(/\\//, $dirname));\n    }\n\n    # Create directory if it doesn't exists\n    if (not -d $dir) {\n        make_path($dir) or do {\n            warn \"[!] Can't create path `$dir`: $!\\n\";\n            return;\n        };\n    }\n\n    my $file = catfile($dir, \"$name.md\");\n\n    if (not $overwrite) {\n        return 1 if -e $file;    # Don't overwrite existent files\n    }\n\n    say \"** Creating file: $file\";\n    open(my $fh, '>:encoding(UTF-8)', $file) or do {\n        warn \"[!] Can't create file `$file`: $!\";\n        return;\n    };\n    print {$fh} $markdown;\n    close $fh;\n}\n\n#\n## MAIN\n#\n\nmy $cache_dir  = 'cache';\nmy $lang       = 'Sidef';\nmy $lang_alias = undef;\nmy $overwrite  = 0;\n\nmy $base_dir = 'programming_tasks';\nmy $main_url = 'https://rosettacode.org';\n\nsub usage {\n    print <<\"EOT\";\nusage: $0 [options]\n\noptions:\n    --lang=s        : the programming language name (default: $lang)\n    --base-dir=s    : where to save the files (default: $base_dir)\n    --overwrite!    : overwrite existent files (default: $overwrite)\n\n    --cache-dir=s   : cache directory (default: $cache_dir)\n    --main-url=s    : main URL (default: $main_url)\n\n    --help          : print this message and exit\n\nexample:\n    $0 --lang=Perl --base-dir=perl_tasks\nEOT\n\n    exit;\n}\n\nGetOptions(\n           'cache-dir=s'  => \\$cache_dir,\n           'L|language=s' => \\$lang,\n           'base-dir=s'   => \\$base_dir,\n           'main-url=s'   => \\$main_url,\n           'overwrite!'   => \\$overwrite,\n           'help'         => \\&usage,\n          )\n  or die \"[!] Error in command line arguments!\";\n\nif (not -d $cache_dir) {\n    mkdir($cache_dir);\n}\n\nmy $lwp = LWP::UserAgent::Cached->new(\n    timeout       => 60,\n    show_progress => 1,\n    agent         => '',\n    cache_dir     => $cache_dir,\n\n    nocache_if => sub {\n        my ($response) = @_;\n        my $code = $response->code;\n        return 1 if ($code >= 300);                           # do not cache any bad response\n        return 1 if ($code == 401);                           # don't cache an unauthorized response\n        return 1 if ($response->request->method ne 'GET');    # cache only GET requests\n        return;\n    },\n);\n\n{\n    my $accepted_encodings = HTTP::Message::decodable();\n    $lwp->default_header('Accept-Encoding' => $accepted_encodings);\n\n    require LWP::ConnCache;\n    my $cache = LWP::ConnCache->new;\n    $cache->total_capacity(undef);    # no limit\n    $lwp->conn_cache($cache);\n}\n\nmy @tasks = extract_all_tasks($main_url, '/wiki/' . escape_lang($lang), $lang);\n\nsub my_uri_escape ($path) {\n    $path =~ s/([?'+])/uri_escape($1)/egr;\n}\n\nforeach my $task (@tasks) {\n\n    my $name  = $task->{name};\n    my $title = $task->{title};\n    my $url   = \"$main_url/wiki/\" . my_uri_escape($name);\n\n    my $resp = $lwp->get($url);\n\n    if ($resp->is_success) {\n\n        my $content   = $resp->decoded_content;\n        my $lang_data = extract_lang($content, $lang, $lang_alias) // do { $lwp->uncache; next };\n\n        my $header   = \"[1]: $url\\n\\n\" . \"# [$title][1]\\n\\n\";\n        my $markdown = $header . to_markdown($lang_data) . \"\\n\";\n\n        write_to_file($base_dir, $name, $markdown, $overwrite);\n    }\n    else {\n        warn \"[\" . $resp->status_line . \"] Can't fetch: $url\\n\";\n    }\n}\n"
  },
  {
    "path": "Book tools/update_summary.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 24 April 2015\n# Website: https://github.com/trizen\n\n# Add a given directory to a given section in SUMMARY.md (for gitbooks)\n\nuse 5.014;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse Cwd qw(getcwd);\nuse File::Basename qw(basename dirname);\nuse File::Spec::Functions qw(rel2abs);\n\nsub add_section {\n    my ($name, $section, $file) = @_;\n\n    my ($before, $middle, $after);\n    open my $fh, '<', $file;\n    while (defined(my $line = <$fh>)) {\n        if ($line =~ /^(\\*\\h+\\Q$name\\E)\\h*$/ || $line =~ m{^(\\*\\h+\\[\\Q$name\\E\\](?:\\(.*\\))?)\\h*$}) {\n\n            $middle = \"$1\\n\";\n            say \"** Found section: <<<$1>>>\";\n            while (defined(my $line = <$fh>)) {\n                if ($line =~ /^\\S/) {\n                    $after = $line;\n                }\n            }\n        }\n        else {\n            if (defined $after) {\n                $after .= $line;\n            }\n            else {\n                $before .= $line;\n            }\n        }\n    }\n    close $fh;\n\n    open my $out_fh, '>', $file;\n    print {$out_fh} $before . $middle . $section . $after;\n    close $out_fh;\n}\n\nmy $summary_file = 'SUMMARY.md';\n\nmy $main_dir     = 'programming_tasks';\nmy $section_name = 'Programming tasks';\n\n{\n    my @root;\n\n    sub make_section {\n        my ($name, $dir, $spaces) = @_;\n\n        my $cwd = getcwd();\n\n        chdir $dir;\n        my @files = map { {name => $_, path => rel2abs($_)} } glob('*');    # sorting for free\n        chdir $cwd;\n\n        my $make_section_url = sub {\n            my ($name) = @_;\n            join('/', basename($main_dir), @root, $name);\n        };\n\n        my %ignored;\n        my $section = '';\n        foreach my $file (@files) {\n            my $title = $file->{name} =~ s/_/ /gr;\n\n            if (-d $file->{path}) {\n\n                if (-e \"$file->{path}.md\") {\n                    my $url_path = $make_section_url->(\"$file->{name}.md\");\n                    $section .= (' ' x $spaces) . \"* [\\u$title]($url_path)\\n\";\n                    $ignored{\"$file->{name}.md\"}++;    # ignore this file later\n                }\n                else {\n                    $section .= (' ' x $spaces) . \"* $title\\n\";\n                }\n\n                push @root, $file->{name};\n                $section .= make_section($file->{name}, $file->{path}, $spaces + 4);\n            }\n            else {\n                next if $dir eq $main_dir;\n                next if $ignored{$file->{name}};\n                my $naked_name  = $file->{name} =~ s/\\.md\\z//ir;\n                my $naked_title = $title =~ s/\\.md\\z//ir;\n                my $url_path    = $make_section_url->($file->{name});\n                $section .= (' ' x $spaces) . \"* [\\u$naked_title]($url_path)\\n\";\n            }\n        }\n\n        pop @root;\n        return $section;\n    }\n}\n\nmy $section = make_section($section_name, $main_dir, 3);\nmy $section_content = add_section($section_name, $section, $summary_file);\n\nsay \"** All done!\";\n"
  },
  {
    "path": "Compression/High-level/ablz_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 June 2023\n# Edit: 31 July 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Adaptive Binary Coding, followed by LZ77 compression (LZ4-like) on bits + Bzip2 on the literals.\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'ABLZ',\n    VERSION => '0.01',\n    FORMAT  => 'ablz',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\nlocal $Compression::Util::LZ_MIN_LEN       = 8 * 4;      # minimum match length\nlocal $Compression::Util::LZ_MAX_LEN       = 1 << 15;    # maximum match length\nlocal $Compression::Util::LZ_MAX_CHAIN_LEN = 64;         # higher value = better compression\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        my $bits = unpack('B*', abc_encode(string2symbols($chunk)));\n        my ($uncompressed, $distances, $lengths, $matches) = lz77_encode($bits);\n        my $ubits = pack('C*', @$uncompressed);\n        my $rem   = length($ubits) % 8;\n        my $str   = pack('B*', $ubits);\n        print $out_fh chr($rem);\n        print $out_fh mrl_compress_symbolic($str);\n        print $out_fh create_huffman_entry($lengths);\n        print $out_fh create_huffman_entry($matches);\n        print $out_fh obh_encode($distances, \\&mrl_compress_symbolic);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        my $rem   = ord getc $fh;\n        my $str   = symbols2string(mrl_decompress_symbolic($fh));\n        my $ubits = unpack('B*', $str);\n        if ($rem != 0) {\n            $ubits = substr($ubits, 0, -(8 - $rem));\n        }\n        my $uncompressed = [unpack('C*', $ubits)];\n        my $lengths      = decode_huffman_entry($fh);\n        my $matches      = decode_huffman_entry($fh);\n        my $distances    = obh_decode($fh, \\&mrl_decompress_symbolic);\n        my $bits         = lz77_decode($uncompressed, $distances, $lengths, $matches);\n        print $out_fh symbols2string(abc_decode(pack('B*', $bits)));\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/bbwr_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 04 July 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Binary Burrows-Wheeler Transform (BWT) + Binary Variable Run-Length Encoding.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n#\n#   Data Compression (Summer 2023) - Lecture 5 - Basic Techniques\n#   https://youtube.com/watch?v=TdFWb8mL5Gk\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'BBWR',\n    VERSION => '0.01',\n    FORMAT  => 'bbwr',\n\n    CHUNK_SIZE => 1 << 13,    # larger values == better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my $bits  = unpack('B*', $chunk);\n    my $vrle1 = binary_vrl_encode($bits);\n\n    if (length($vrle1) < length($bits)) {\n        printf \"Doing early VLR, saving %s bits\\n\", length($bits) - length($vrle1);\n        print $out_fh chr(1);\n    }\n    else {\n        print $out_fh chr(0);\n        $vrle1 = $bits;\n    }\n\n    my ($bwt, $idx) = bwt_encode($vrle1);\n    my $vrle2 = binary_vrl_encode($bwt);\n\n    say \"BWT index: $idx\";\n\n    print $out_fh pack('N',  $idx);\n    print $out_fh pack('N',  length($vrle2));\n    print $out_fh pack('B*', $vrle2);\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $compressed_byte = ord(getc($fh) // die \"error\");\n\n    my $idx      = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    my $bits_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n\n    say \"BWT index = $idx\";\n\n    my $bwt  = binary_vrl_decode(read_bits($fh, $bits_len));\n    my $data = bwt_decode($bwt, $idx);\n\n    if ($compressed_byte == 1) {\n        $data = binary_vrl_decode($data);\n    }\n\n    print $out_fh pack('B*', $data);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/blzss2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 June 2023\n# Edit: 29 July 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression (LZ4-like) on bits + Huffman coding + Bzip2 on the literals.\n\n# Good at compressing data where there are patterns on bits, but not at byte boundaries (e.g.: variable-bit encoded data).\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'BLZSS2',\n    VERSION => '0.01',\n    FORMAT  => 'blzss2',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        my $bits = unpack('B*', $chunk);\n        my ($uncompressed, $distances, $lengths, $matches) = do {\n            local $Compression::Util::LZ_MIN_LEN       = 8 * 4;      # minimum match length\n            local $Compression::Util::LZ_MAX_LEN       = 1 << 15;    # maximum match length\n            local $Compression::Util::LZ_MAX_CHAIN_LEN = 64;         # higher value = better compression\n            lz77_encode($bits);\n        };\n        my $ubits = pack('C*', @$uncompressed);\n        my $rem   = length($ubits) % 8;\n        my $str   = pack('B*', $ubits);\n        print $out_fh chr($rem);\n        print $out_fh mrl_compress_symbolic($str, \\&lzss_compress_symbolic);\n        print $out_fh create_huffman_entry($lengths);\n        print $out_fh create_huffman_entry($matches);\n        print $out_fh obh_encode($distances, \\&mrl_compress_symbolic);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        my $rem   = ord getc $fh;\n        my $str   = symbols2string(mrl_decompress_symbolic($fh, \\&lzss_decompress_symbolic));\n        my $ubits = unpack('B*', $str);\n        if ($rem != 0) {\n            $ubits = substr($ubits, 0, -(8 - $rem));\n        }\n        my $uncompressed = [unpack('C*', $ubits)];\n        my $lengths      = decode_huffman_entry($fh);\n        my $matches      = decode_huffman_entry($fh);\n        my $distances    = obh_decode($fh, \\&mrl_decompress_symbolic);\n        my $bits         = lz77_decode($uncompressed, $distances, $lengths, $matches);\n        print $out_fh pack('B*', $bits);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/blzss_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 June 2023\n# Edit: 25 July 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression (LZ4-like) on bits + Huffman coding.\n\n# Good at compressing data where there are patterns on bits, but not at byte boundaries (e.g.: variable-bit encoded data).\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'BLZSS',\n    VERSION => '0.01',\n    FORMAT  => 'blzss',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        my $bits = unpack('B*', $chunk);\n        my ($uncompressed, $distances, $lengths, $matches) = do {\n            local $Compression::Util::LZ_MIN_LEN       = 8 * 5;      # minimum match length\n            local $Compression::Util::LZ_MAX_LEN       = 1 << 15;    # maximum match length\n            local $Compression::Util::LZ_MAX_CHAIN_LEN = 64;         # higher value = better compression\n            lz77_encode($bits);\n        };\n        my $ubits = pack('C*', @$uncompressed);\n        my $rem   = length($ubits) % 8;\n        my $str   = pack('B*', $ubits);\n        print $out_fh chr($rem);\n        print $out_fh mrl_compress_symbolic($str, \\&lzss_compress_symbolic);\n        print $out_fh create_huffman_entry($lengths);\n        print $out_fh create_huffman_entry($matches);\n        print $out_fh obh_encode($distances, \\&mrl_compress_symbolic);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        my $rem   = ord getc $fh;\n        my $str   = symbols2string(mrl_decompress_symbolic($fh, \\&lzss_decompress_symbolic));\n        my $ubits = unpack('B*', $str);\n        if ($rem != 0) {\n            $ubits = substr($ubits, 0, -(8 - $rem));\n        }\n        my $uncompressed = [unpack('C*', $ubits)];\n        my $lengths      = decode_huffman_entry($fh);\n        my $matches      = decode_huffman_entry($fh);\n        my $distances    = obh_decode($fh, \\&mrl_decompress_symbolic);\n        my $bits         = lz77_decode($uncompressed, $distances, $lengths, $matches);\n        print $out_fh pack('B*', $bits);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/brlzss_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 June 2023\n# Edit: 25 July 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Binary RLE + LZ77 compression (LZ4-like) + Huffman coding.\n\n# Good at compressing data where there are patterns on bits, but not at byte boundaries (e.g.: variable-bit encoded data).\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'BRLZSS',\n    VERSION => '0.01',\n    FORMAT  => 'brlzss',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        my $bits = unpack('B*', $chunk);\n        my $rle  = binary_vrl_encode($bits);\n        if (length($rle) >= length($bits)) {\n            print $out_fh chr(0);\n            printf(\"Without binary VRLE: %s >= %s\\n\", length($rle), length($bits));\n            $rle = $bits;\n        }\n        else {\n            print $out_fh chr(1);\n            printf(\"With binary VRLE: %s < %s\\n\", length($rle), length($bits));\n        }\n        my ($uncompressed, $distances, $lengths, $matches) = do {\n            local $Compression::Util::LZ_MIN_LEN       = 8 * 3;      # minimum match length\n            local $Compression::Util::LZ_MAX_LEN       = 1 << 15;    # maximum match length\n            local $Compression::Util::LZ_MAX_CHAIN_LEN = 64;         # higher value = better compression\n            lz77_encode($rle);\n        };\n        my $ubits = pack('C*', @$uncompressed);\n\n        print $out_fh chr(length($ubits) % 8);\n\n        my $str = pack('B*', $ubits);\n        print $out_fh mrl_compress_symbolic($str, \\&lzss_compress_symbolic);\n        print $out_fh create_huffman_entry($lengths);\n        print $out_fh create_huffman_entry($matches);\n        print $out_fh obh_encode($distances, \\&mrl_compress_symbolic);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        my $with_vrle = ord getc($fh);\n        my $rem       = ord getc($fh);\n        my $str       = symbols2string(mrl_decompress_symbolic($fh, \\&lzss_decompress_symbolic));\n        my $ubits     = unpack('B*', $str);\n        if ($rem != 0) {\n            $ubits = substr($ubits, 0, -(8 - $rem));\n        }\n        my $uncompressed = [unpack('C*', $ubits)];\n        my $lengths      = decode_huffman_entry($fh);\n        my $matches      = decode_huffman_entry($fh);\n        my $distances    = obh_decode($fh, \\&mrl_decompress_symbolic);\n        my $rle          = lz77_decode($uncompressed, $distances, $lengths, $matches);\n        my $bits         = $with_vrle ? binary_vrl_decode($rle) : $rle;\n        print $out_fh pack('B*', $bits);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/bwac_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 14 June 2023\n# Edit: 13 April 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-Front Transform + Run-length encoding + Arithmetic Coding.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n#\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'BWAC',\n    VERSION => '0.02',\n    FORMAT  => 'bwac',\n\n    CHUNK_SIZE => 1 << 17,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(2);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh bwt_compress($chunk, \\&create_ac_entry);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        print $out_fh bwt_decompress($fh, \\&decode_ac_entry);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/bwad_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 14 June 2023\n# Edit: 21 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-Front Transform + Run-length encoding + Adaptive Arithmetic Coding (in fixed bits).\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n#\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'BWAD',\n    VERSION => '0.02',\n    FORMAT  => 'bwad',\n\n    CHUNK_SIZE => 1 << 17,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(2);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh bwt_compress($chunk, \\&create_adaptive_ac_entry);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        print $out_fh bwt_decompress($fh, \\&decode_adaptive_ac_entry);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/bwlz2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 June 2023\n# Edit: 13 April 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + LZ77 compression + Symbolic Bzip2.\n\n# Encoding the literals and the pointers using a DEFLATE-like approach.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n#\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse List::Util        qw(max uniq);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'BWLZ2',\n    VERSION => '0.01',\n    FORMAT  => 'bwlz2',\n\n    CHUNK_SIZE => 1 << 17,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my @chunk_bytes = unpack('C*', $chunk);\n    my $data        = pack('C*', @{rle4_encode(\\@chunk_bytes, 254)});\n\n    my ($bwt, $idx) = bwt_encode($data);\n\n    my @bytes    = unpack('C*', $bwt);\n    my @alphabet = sort { $a <=> $b } uniq(@bytes);\n\n    my $enc_bytes = mtf_encode(\\@bytes, \\@alphabet);\n\n    if (max(@$enc_bytes) < 255) {\n        print $out_fh chr(1);\n        $enc_bytes = zrle_encode($enc_bytes);\n    }\n    else {\n        print $out_fh chr(0);\n        $enc_bytes = rle4_encode($enc_bytes);\n    }\n\n    print $out_fh pack('N', $idx);\n    print $out_fh encode_alphabet(\\@alphabet);\n    print $out_fh lzss_compress(pack('C*', @$enc_bytes), \\&bwt_compress_symbolic);\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $rle_encoded = ord(getc($fh) // die \"error\");\n    my $idx         = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    my $alphabet    = decode_alphabet($fh);\n\n    my $dec   = lzss_decompress($fh, \\&bwt_decompress_symbolic);\n    my $bytes = [unpack('C*', $dec)];\n\n    if ($rle_encoded) {\n        $bytes = zrle_decode($bytes);\n    }\n    else {\n        $bytes = rle4_decode($bytes);\n    }\n\n    $bytes = mtf_decode($bytes, $alphabet);\n\n    print $out_fh symbols2string(rle4_decode(string2symbols(bwt_decode(pack('C*', @$bytes), $idx))));\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the files\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/bwlz3_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 June 2023\n# Edit: 02 May 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-front transform (MTF) + ZRLE + LZHD compression.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n#\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse List::Util        qw(max uniq);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'BWLZ3',\n    VERSION => '0.01',\n    FORMAT  => 'bwlz3',\n\n    CHUNK_SIZE => 1 << 17,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my $lzb = do {\n        local $Compression::Util::LZ_MIN_LEN = 512;\n        lzb_compress($chunk);\n    };\n\n    my @chunk_bytes = unpack('C*', $lzb);\n    my $data        = rle4_encode(\\@chunk_bytes, scalar(@chunk_bytes));\n\n    my ($bwt,       $idx)      = bwt_encode_symbolic($data);\n    my ($enc_bytes, $alphabet) = mtf_encode($bwt);\n\n    $enc_bytes = zrle_encode($enc_bytes);\n\n    print $out_fh pack('N', $idx);\n    print $out_fh encode_alphabet($alphabet);\n    print $out_fh lz77_compress_symbolic($enc_bytes);\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $idx      = bytes2int($fh, 4);\n    my $alphabet = decode_alphabet($fh);\n\n    my $symbols = lz77_decompress_symbolic($fh);\n\n    $symbols = zrle_decode($symbols);\n    $symbols = mtf_decode($symbols, $alphabet);\n\n    print $out_fh lzb_decompress(symbols2string(rle4_decode(bwt_decode_symbolic($symbols, $idx))));\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the files\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/bwlz_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 June 2023\n# Edit: 21 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-front transform (MTF) + LZ77 compression (LZSS) + Huffman coding.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n#\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse List::Util        qw(max uniq);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'BWLZ',\n    VERSION => '0.05',\n    FORMAT  => 'bwlz',\n\n    CHUNK_SIZE => 1 << 17,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(5);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my @chunk_bytes = unpack('C*', $chunk);\n    my $data        = pack('C*', @{rle4_encode(\\@chunk_bytes, 254)});\n\n    my ($bwt, $idx) = bwt_encode($data);\n\n    my @bytes    = unpack('C*', $bwt);\n    my @alphabet = sort { $a <=> $b } uniq(@bytes);\n\n    my $enc_bytes = mtf_encode(\\@bytes, \\@alphabet);\n\n    if (max(@$enc_bytes) < 255) {\n        print $out_fh chr(1);\n        $enc_bytes = zrle_encode($enc_bytes);\n    }\n    else {\n        print $out_fh chr(0);\n        $enc_bytes = rle4_encode($enc_bytes);\n    }\n\n    print $out_fh pack('N', $idx);\n    print $out_fh encode_alphabet(\\@alphabet);\n    print $out_fh lzss_compress(pack('C*', @$enc_bytes));\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $rle_encoded = ord(getc($fh) // die \"error\");\n    my $idx         = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    my $alphabet    = decode_alphabet($fh);\n\n    my $dec   = lzss_decompress($fh);\n    my $bytes = [unpack('C*', $dec)];\n\n    if ($rle_encoded) {\n        $bytes = zrle_decode($bytes);\n    }\n    else {\n        $bytes = rle4_decode($bytes);\n    }\n\n    $bytes = mtf_decode($bytes, $alphabet);\n\n    print $out_fh symbols2string(rle4_decode(string2symbols(bwt_decode(pack('C*', @$bytes), $idx))));\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the files\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/bwlza2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 June 2023\n# Edit: 19 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + LZ77 compression (LZHD variant) + Arithmetic Coding (in fixed bits).\n\n# Encoding the distances using a DEFLATE-like approach.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n#\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n#\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse List::Util        qw(uniq max);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'BWLZA2',\n    VERSION => '0.01',\n    FORMAT  => 'bwlza2',\n\n    CHUNK_SIZE => 1 << 17,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lzad_compression ($chunk, $out_fh) {\n\n    my ($uncompressed, $distances, $lengths, $matches) = lz77_encode($chunk);\n\n    my $est_ratio = length($chunk) / (4 * scalar(@$uncompressed));\n    say(scalar(@$uncompressed), ' -> ', $est_ratio);\n\n    print $out_fh create_ac_entry($uncompressed);\n    print $out_fh create_ac_entry($lengths);\n    print $out_fh create_ac_entry($matches);\n    print $out_fh obh_encode($distances, \\&create_ac_entry);\n}\n\nsub lzad_decompression ($fh) {\n\n    my $uncompressed = decode_ac_entry($fh);\n    my $lengths      = decode_ac_entry($fh);\n    my $matches      = decode_ac_entry($fh);\n    my $distances    = obh_decode($fh, \\&decode_ac_entry);\n\n    return lz77_decode($uncompressed, $distances, $lengths, $matches);\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my @chunk_bytes = unpack('C*', $chunk);\n    my $data        = pack('C*', @{rle4_encode(\\@chunk_bytes, 254)});\n\n    my ($bwt, $idx) = bwt_encode($data);\n\n    my @bytes    = unpack('C*', $bwt);\n    my @alphabet = sort { $a <=> $b } uniq(@bytes);\n\n    my $enc_bytes = mtf_encode(\\@bytes, [@alphabet]);\n\n    if (max(@$enc_bytes) < 255) {\n        print $out_fh chr(1);\n        $enc_bytes = zrle_encode($enc_bytes);\n    }\n    else {\n        print $out_fh chr(0);\n        $enc_bytes = rle4_encode($enc_bytes);\n    }\n\n    print $out_fh pack('N', $idx);\n    print $out_fh encode_alphabet(\\@alphabet);\n    lzad_compression(pack('C*', @$enc_bytes), $out_fh);\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $rle_encoded = ord(getc($fh) // die \"error\");\n    my $idx         = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    my $alphabet    = decode_alphabet($fh);\n\n    my $bytes = string2symbols(lzad_decompression($fh));\n\n    if ($rle_encoded) {\n        $bytes = zrle_decode($bytes);\n    }\n    else {\n        $bytes = rle4_decode($bytes);\n    }\n\n    $bytes = mtf_decode($bytes, [@$alphabet]);\n\n    print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode(pack('C*', @$bytes), $idx))])});\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/bwlza_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 June 2023\n# Edit: 21 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-front transform (MTF) + LZ77 compression (LZSS) + Arithmetic Coding (in fixed bits).\n\n# Encoding the literals and the pointers using a DEFLATE-like approach.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n#\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n#\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse List::Util        qw(max uniq);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'BWLZA',\n    VERSION => '0.03',\n    FORMAT  => 'bwlza',\n\n    CHUNK_SIZE => 1 << 17,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(3);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my @chunk_bytes = unpack('C*', $chunk);\n    my $data        = pack('C*', @{rle4_encode(\\@chunk_bytes, 254)});\n\n    my ($bwt, $idx) = bwt_encode($data);\n\n    my @bytes    = unpack('C*', $bwt);\n    my @alphabet = sort { $a <=> $b } uniq(@bytes);\n\n    my $enc_bytes = mtf_encode(\\@bytes, \\@alphabet);\n\n    if (max(@$enc_bytes) < 255) {\n        print $out_fh chr(1);\n        $enc_bytes = zrle_encode($enc_bytes);\n    }\n    else {\n        print $out_fh chr(0);\n        $enc_bytes = rle4_encode($enc_bytes);\n    }\n\n    print $out_fh pack('N', $idx);\n    print $out_fh encode_alphabet(\\@alphabet);\n    print $out_fh lzss_compress(pack('C*', @$enc_bytes), \\&create_ac_entry);\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $rle_encoded = ord(getc($fh) // die \"error\");\n    my $idx         = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    my $alphabet    = decode_alphabet($fh);\n\n    my $dec   = lzss_decompress($fh, \\&decode_ac_entry);\n    my $bytes = [unpack('C*', $dec)];\n\n    if ($rle_encoded) {\n        $bytes = zrle_decode($bytes);\n    }\n    else {\n        $bytes = rle4_decode($bytes);\n    }\n\n    $bytes = mtf_decode($bytes, $alphabet);\n\n    print $out_fh symbols2string(rle4_decode(string2symbols(bwt_decode(pack('C*', @$bytes), $idx))));\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/bwlzad2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 June 2023\n# Edit: 19 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-front transform (MTF) + LZ77 compression (LZHD variant) + Adaptive Arithmetic Coding (in fixed bits).\n\n# Encoding the distances using a DEFLATE-like approach.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n#\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n#\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse List::Util        qw(max uniq);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'BWLZAD2',\n    VERSION => '0.01',\n    FORMAT  => 'bwlzad2',\n\n    CHUNK_SIZE => 1 << 17,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lzhd_compression ($chunk, $out_fh) {\n\n    my ($uncompressed, $distances, $lengths, $matches) = lz77_encode($chunk);\n\n    my $est_ratio = length($chunk) / (4 * scalar(@$uncompressed));\n    say(scalar(@$uncompressed), ' -> ', $est_ratio);\n\n    print $out_fh create_ac_entry($uncompressed);\n    print $out_fh create_ac_entry($lengths);\n    print $out_fh create_ac_entry($matches);\n    print $out_fh abc_encode($distances);\n}\n\nsub lzhd_decompression ($fh) {\n\n    my $uncompressed = decode_ac_entry($fh);\n    my $lengths      = decode_ac_entry($fh);\n    my $matches      = decode_ac_entry($fh);\n    my $distances    = abc_decode($fh);\n\n    return lz77_decode($uncompressed, $distances, $lengths, $matches);\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my @chunk_bytes = unpack('C*', $chunk);\n    my $data        = pack('C*', @{rle4_encode(\\@chunk_bytes)});\n\n    my ($bwt, $idx) = bwt_encode($data);\n\n    my @bytes    = unpack('C*', $bwt);\n    my @alphabet = sort { $a <=> $b } uniq(@bytes);\n\n    my $enc_bytes = mtf_encode(\\@bytes, [@alphabet]);\n\n    if (max(@$enc_bytes) < 255) {\n        print $out_fh chr(1);\n        $enc_bytes = zrle_encode($enc_bytes);\n    }\n    else {\n        print $out_fh chr(0);\n        $enc_bytes = rle4_encode($enc_bytes);\n    }\n\n    print $out_fh pack('N', $idx);\n    print $out_fh encode_alphabet(\\@alphabet);\n    lzhd_compression(pack('C*', @$enc_bytes), $out_fh);\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $rle_encoded = ord(getc($fh) // die \"error\");\n    my $idx         = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    my $alphabet    = decode_alphabet($fh);\n\n    my $bytes = string2symbols(lzhd_decompression($fh));\n\n    if ($rle_encoded) {\n        $bytes = zrle_decode($bytes);\n    }\n    else {\n        $bytes = rle4_decode($bytes);\n    }\n\n    $bytes = mtf_decode($bytes, [@$alphabet]);\n\n    print $out_fh symbols2string(rle4_decode(string2symbols(bwt_decode(pack('C*', @$bytes), $idx))));\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/bwlzad_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 June 2023\n# Edit: 07 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-front transform (MTF) + LZ77 compression (LZSS) + Adaptive Arithmetic Coding (in fixed bits).\n\n# Encoding the literals and the pointers using a DEFLATE-like approach.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n#\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n#\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse List::Util        qw(max uniq);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'BWLZAD',\n    VERSION => '0.01',\n    FORMAT  => 'bwlzad',\n\n    CHUNK_SIZE => 1 << 17,    # higher value = better compression\n};\n\n# Arithmetic Coding settings\nuse constant BITS         => 32;\nuse constant MAX          => oct('0b' . ('1' x BITS));\nuse constant INITIAL_FREQ => 1;\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my @chunk_bytes = unpack('C*', $chunk);\n    my $data        = pack('C*', @{rle4_encode(\\@chunk_bytes, 254)});\n\n    my ($bwt, $idx) = bwt_encode($data);\n\n    my @bytes    = unpack('C*', $bwt);\n    my @alphabet = sort { $a <=> $b } uniq(@bytes);\n\n    my $enc_bytes = mtf_encode(\\@bytes, \\@alphabet);\n\n    if (max(@$enc_bytes) < 255) {\n        print $out_fh chr(1);\n        $enc_bytes = zrle_encode($enc_bytes);\n    }\n    else {\n        print $out_fh chr(0);\n        $enc_bytes = rle4_encode($enc_bytes);\n    }\n\n    print $out_fh pack('N', $idx);\n    print $out_fh encode_alphabet(\\@alphabet);\n    print $out_fh lzss_compress(pack('C*', @$enc_bytes), \\&create_adaptive_ac_entry);\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $rle_encoded = ord(getc($fh) // die \"error\");\n    my $idx         = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    my $alphabet    = decode_alphabet($fh);\n\n    my $bytes = [unpack('C*', lzss_decompress($fh, \\&decode_adaptive_ac_entry))];\n\n    if ($rle_encoded) {\n        $bytes = zrle_decode($bytes);\n    }\n    else {\n        $bytes = rle4_decode($bytes);\n    }\n\n    $bytes = mtf_decode($bytes, $alphabet);\n\n    print $out_fh symbols2string(rle4_decode(string2symbols(bwt_decode(pack('C*', @$bytes), $idx))));\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/bwlzb_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 03 June 2024\n# https://github.com/trizen\n\n# Compress/decompress files using byte-aligned LZ77 compression (LZSS) + Burrows-Wheeler Transform (BWT) + Move-to-front transform (MTF) + Huffman coding.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n#\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse List::Util        qw(max uniq);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'BWLZB',\n    VERSION => '0.01',\n    FORMAT  => 'bwlzb',\n\n    CHUNK_SIZE => 1 << 17,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(5);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub compression ($chunk, $out_fh) {\n\n    local $Compression::Util::LZ_MIN_LEN = 64;\n\n    my $rle4 = symbols2string(rle4_encode(string2symbols($chunk)));\n    my $lzb  = lzb_compress($rle4);\n    my ($bwt, $idx) = bwt_encode($lzb);\n\n    my ($mtf, $alphabet) = mtf_encode(string2symbols($bwt));\n    my $rle = zrle_encode($mtf);\n\n    my $enc = pack('N', $idx) . encode_alphabet($alphabet) . create_huffman_entry($rle);\n\n    print $out_fh $enc;\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $idx      = bytes2int($fh, 4);\n    my $alphabet = decode_alphabet($fh);\n    my $rle      = decode_huffman_entry($fh);\n\n    my $mtf = zrle_decode($rle);\n    my $bwt = symbols2string(mtf_decode($mtf, $alphabet));\n    my $lzb = bwt_decode($bwt, $idx);\n\n    my $rle4 = lzb_decompress($lzb);\n    my $data = symbols2string(rle4_decode(string2symbols($rle4)));\n    print $out_fh $data;\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the files\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/bwlzhd2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# Edit: 25 July 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler transform (BWT) + Run-length Encoding (RLE) + LZ77 compression (LZ4-like) + Move-to-front + Huffman coding.\n\n# Encoding the distances/indices using a DEFLATE-like approach.\n\nuse 5.036;\n\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'BWLZHD2',\n    VERSION => '0.01',\n    FORMAT  => 'bwlzhd2',\n\n    CHUNK_SIZE => 1 << 17,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my $rle4 = rle4_encode([unpack('C*', $chunk)]);\n    my ($bwt, $idx) = bwt_encode(pack('C*', @$rle4));\n\n    say \"BWT index = $idx\";\n\n    my ($uncompressed, $distances, $lengths, $matches) = lz77_encode($bwt);\n    my $est_ratio = length($chunk) / (4 * scalar(@$uncompressed));\n\n    say(scalar(@$uncompressed), ' -> ', $est_ratio);\n\n    print $out_fh pack('N', $idx);\n    print $out_fh mrl_compress_symbolic($uncompressed);\n    print $out_fh create_huffman_entry($lengths);\n    print $out_fh create_huffman_entry($matches);\n    print $out_fh obh_encode($distances, \\&mrl_compress_symbolic);\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $idx          = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4));\n    my $uncompressed = mrl_decompress_symbolic($fh);\n    my $lengths      = decode_huffman_entry($fh);\n    my $matches      = decode_huffman_entry($fh);\n    my $distances    = obh_decode($fh, \\&mrl_decompress_symbolic);\n\n    my $bwt  = lz77_decode($uncompressed, $distances, $lengths, $matches);\n    my @rle4 = unpack('C*', bwt_decode($bwt, $idx));\n    print $out_fh symbols2string(rle4_decode(\\@rle4));\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/bwlzhd_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# Edit: 19 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler transform (BWT) + Run-length Encoding (RLE) + LZ77 compression (LZHD variant) + Huffman coding.\n\n# Encoding the distances/indices using a DEFLATE-like approach.\n\nuse 5.036;\n\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'BWLZHD',\n    VERSION => '0.02',\n    FORMAT  => 'bwlzhd',\n\n    CHUNK_SIZE => 1 << 17,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(2);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my $rle4 = rle4_encode([unpack('C*', $chunk)]);\n    my ($bwt, $idx) = bwt_encode(pack('C*', @$rle4));\n\n    $bwt = pack('C*', @{rle4_encode([unpack('C*', $bwt)])});\n\n    say \"BWT index = $idx\";\n\n    my ($uncompressed, $distances, $lengths, $matches) = lz77_encode($bwt);\n    my $est_ratio = length($chunk) / (4 * scalar(@$uncompressed));\n\n    say(scalar(@$uncompressed), ' -> ', $est_ratio);\n\n    print $out_fh pack('N', $idx);\n    print $out_fh mrl_compress_symbolic($uncompressed);\n    print $out_fh create_huffman_entry($lengths);\n    print $out_fh create_huffman_entry($matches);\n    print $out_fh obh_encode($distances);\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $idx          = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4));\n    my $uncompressed = mrl_decompress_symbolic($fh);\n    my $lengths      = decode_huffman_entry($fh);\n    my $matches      = decode_huffman_entry($fh);\n    my $distances    = obh_decode($fh);\n\n    my $rle4 = lz77_decode($uncompressed, $distances, $lengths, $matches);\n    my $bwt  = symbols2string(rle4_decode(string2symbols($rle4)));\n    my @rle4 = unpack('C*', bwt_decode($bwt, $idx));\n    print $out_fh symbols2string(rle4_decode(\\@rle4));\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/bwlzss_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 June 2023\n# Edit: 21 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + LZ77 compression (LZSS) + Huffman coding.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n#\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'BWLZSS',\n    VERSION => '0.01',\n    FORMAT  => 'bwlzss',\n\n    CHUNK_SIZE => 1 << 17,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my $rle4 = rle4_encode([unpack('C*', $chunk)]);\n    my ($bwt, $idx) = bwt_encode(pack('C*', @$rle4));\n\n    print $out_fh pack('N', $idx);\n    print $out_fh lzss_compress($bwt, \\&mrl_compress_symbolic);\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $idx = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n\n    my $bwt  = lzss_decompress($fh, \\&mrl_decompress_symbolic);\n    my $rle4 = bwt_decode($bwt, $idx);\n    my $data = rle4_decode([unpack('C*', $rle4)]);\n\n    print $out_fh pack('C*', @$data);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/bwrl2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 10 September 2023\n# Edit: 13 April 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Variable Run-Length encoding + Huffman coding.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'BWRL2',\n    VERSION => '0.01',\n    FORMAT  => 'bwrl2',\n\n    CHUNK_SIZE => 1 << 17,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub VLR_encoding ($bytes) {\n\n    my $uncompressed = '';\n    my $bitstream    = '';\n    my $rle          = run_length($bytes);\n\n    foreach my $cv (@$rle) {\n        my ($c, $v) = @$cv;\n        $uncompressed .= chr($c);\n        if ($v == 1) {\n            $bitstream .= '0';\n        }\n        else {\n            my $t = sprintf('%b', $v);\n            $bitstream .= join('', '1' x (length($t) - 1), '0', substr($t, 1));\n        }\n    }\n\n    return ($uncompressed, pack('B*', $bitstream));\n}\n\nsub VLR_decoding ($uncompressed, $bits_fh) {\n\n    my $decoded = '';\n    my $buffer  = '';\n\n    foreach my $c (@$uncompressed) {\n\n        my $bl = 0;\n        while (read_bit($bits_fh, \\$buffer) == 1) {\n            ++$bl;\n        }\n\n        if ($bl > 0) {\n            $decoded .= chr($c) x oct('0b1' . join('', map { read_bit($bits_fh, \\$buffer) } 1 .. $bl));\n        }\n        else {\n            $decoded .= chr($c);\n        }\n    }\n\n    return $decoded;\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my ($bwt,          $idx)     = bwt_encode(symbols2string(rle4_encode($chunk)));\n        my ($uncompressed, $lengths) = VLR_encoding(string2symbols($bwt));\n\n        print $out_fh pack('N', $idx);\n        print $out_fh mrl_compress_symbolic($uncompressed, sub ($s) { lzss_compress_symbolic($s, \\&mrl_compress_symbolic) });\n        print $out_fh create_huffman_entry(rle4_encode(string2symbols($lengths)));\n    }\n\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my $idx          = bytes2int($fh, 4);\n        my $uncompressed = mrl_decompress_symbolic($fh, sub ($s) { lzss_decompress_symbolic($s, \\&mrl_decompress_symbolic) });\n\n        open my $len_fh, '+>:raw', \\my $lengths;\n        print $len_fh symbols2string(rle4_decode(decode_huffman_entry($fh)));\n        seek($len_fh, 0, 0);\n\n        my $dec = VLR_decoding($uncompressed, $len_fh);\n        print $out_fh symbols2string(rle4_decode(bwt_decode($dec, $idx)));\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/bwrm2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 10 September 2023\n# Edit: 13 April 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Run-Length encoding + MTF + ZRLE + Bzip2 on lengths.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'BWRM2',\n    VERSION => '0.01',\n    FORMAT  => 'bwrm2',\n\n    CHUNK_SIZE => 1 << 17,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub VLR_encoding ($bytes) {\n\n    my @lengths;\n    my @uncompressed;\n\n    my $rle = run_length($bytes, 256);\n\n    foreach my $cv (@$rle) {\n        my ($c, $v) = @$cv;\n        push @uncompressed, $c;\n        push @lengths,      $v - 1;\n    }\n\n    return (\\@uncompressed, \\@lengths);\n}\n\nsub VLR_decoding ($uncompressed, $lengths) {\n\n    my $decoded = '';\n\n    foreach my $i (0 .. $#{$uncompressed}) {\n\n        my $c   = $uncompressed->[$i];\n        my $len = $lengths->[$i];\n\n        if ($len > 0) {\n            $decoded .= chr($c) x ($len + 1);\n        }\n        else {\n            $decoded .= chr($c);\n        }\n    }\n\n    return $decoded;\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my ($bwt,          $idx)     = bwt_encode(symbols2string(rle4_encode($chunk)));\n        my ($uncompressed, $lengths) = VLR_encoding(string2symbols($bwt));\n\n        print $out_fh pack('N', $idx);\n\n        print $out_fh mrl_compress_symbolic($uncompressed, \\&lzss_compress_symbolic);\n        print $out_fh bwt_compress(pack('C*', @$lengths));\n    }\n\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my $idx = unpack('N', join('', map { getc($fh) // die \"decompression error\" } 1 .. 4));\n\n        my $uncompressed = mrl_decompress_symbolic($fh, \\&lzss_decompress_symbolic);\n        my $lengths      = bwt_decompress($fh);\n        my $dec          = VLR_decoding($uncompressed, string2symbols($lengths));\n        print $out_fh symbols2string(rle4_decode(bwt_decode($dec, $idx)));\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/bwrm_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 10 September 2023\n# Edit: 13 April 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Run-Length encoding + MTF + ZRLE.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'BWRM',\n    VERSION => '0.01',\n    FORMAT  => 'bwrm',\n\n    CHUNK_SIZE => 1 << 17,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub VLR_encoding ($bytes) {\n\n    my @lengths;\n    my @uncompressed;\n\n    my $rle = run_length($bytes);\n\n    foreach my $cv (@$rle) {\n        my ($c, $v) = @$cv;\n        push @uncompressed, $c;\n        push @lengths,      $v - 1;\n    }\n\n    return (\\@uncompressed, \\@lengths);\n}\n\nsub VLR_decoding ($uncompressed, $lengths) {\n\n    my $decoded = '';\n\n    foreach my $i (0 .. $#{$uncompressed}) {\n\n        my $c   = $uncompressed->[$i];\n        my $len = $lengths->[$i];\n\n        if ($len > 0) {\n            $decoded .= chr($c) x ($len + 1);\n        }\n        else {\n            $decoded .= chr($c);\n        }\n    }\n\n    return $decoded;\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my ($bwt,          $idx)     = bwt_encode(symbols2string(rle4_encode($chunk)));\n        my ($uncompressed, $lengths) = VLR_encoding(string2symbols($bwt));\n\n        print $out_fh pack('N', $idx);\n        print $out_fh mrl_compress_symbolic($uncompressed, \\&lzss_compress_symbolic);\n        print $out_fh create_huffman_entry(rle4_encode($lengths));\n    }\n\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my $idx = unpack('N', join('', map { getc($fh) // die \"decompression error\" } 1 .. 4));\n\n        my $uncompressed = mrl_decompress_symbolic($fh, \\&lzss_decompress_symbolic);\n        my $lengths      = rle4_decode(decode_huffman_entry($fh));\n        my $dec          = VLR_decoding($uncompressed, $lengths);\n        print $out_fh symbols2string(rle4_decode(bwt_decode($dec, $idx)));\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/bwt2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 14 June 2023\n# Edit: 19 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-To-Front transform (MTF) + Run-length encoding (RLE) + Bzip2.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'BWT2',\n    VERSION => '0.01',\n    FORMAT  => 'bwt2',\n\n    CHUNK_SIZE => 1 << 17,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh bwt_compress($chunk, sub ($s) { lzss_compress_symbolic($s, \\&mrl_compress_symbolic) });\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        print $out_fh bwt_decompress($fh, sub ($s) { lzss_decompress_symbolic($s, \\&mrl_decompress_symbolic) });\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/bwt_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 14 June 2023\n# Edit: 21 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-Front Transform + Run-length encoding + Huffman coding.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'BWT',\n    VERSION => '0.02',\n    FORMAT  => 'bwt',\n\n    CHUNK_SIZE => 1 << 17,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(2);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh bwt_compress($chunk);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        print $out_fh bwt_decompress($fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/bzip2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Compress files using Bzip2.\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\n\nuse IO::Compress::Bzip2     qw(bzip2);\nuse IO::Uncompress::Bunzip2 qw(bunzip2);\n\nuse constant {\n              PKGNAME => 'BZIP2',\n              VERSION => '0.01',\n              FORMAT  => 'bz2',\n             };\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Compress data\n    bzip2($fh, $out_fh) or die \"compression error\";\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    bunzip2($fh, $out_fh) or die \"decompression error\";\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/gzip_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Compress files using Gzip.\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\n\nuse IO::Compress::Gzip     qw(gzip);\nuse IO::Uncompress::Gunzip qw(gunzip);\n\nuse constant {\n              PKGNAME => 'GZIP',\n              VERSION => '0.01',\n              FORMAT  => 'gz',\n             };\n\nsub usage ($code = 0) {\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Compress data\n    gzip($fh, $out_fh) or die \"compression error\";\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    gunzip($fh, $out_fh) or die \"decompression error\";\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/hblz_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 June 2023\n# Edit: 31 July 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Huffman coding, followed by LZ77 compression (LZ4-like) on bits + Bzip2 on the literals.\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'HBLZ',\n    VERSION => '0.01',\n    FORMAT  => 'hblz',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        my $bits = unpack('B*', create_huffman_entry(string2symbols($chunk)));\n        my ($uncompressed, $distances, $lengths, $matches) = do {\n            local $Compression::Util::LZ_MIN_LEN       = 8 * 4;      # minimum match length\n            local $Compression::Util::LZ_MAX_LEN       = 1 << 15;    # maximum match length\n            local $Compression::Util::LZ_MAX_CHAIN_LEN = 64;         # higher value = better compression\n            lz77_encode($bits);\n        };\n        my $ubits = pack('C*', @$uncompressed);\n        my $rem   = length($ubits) % 8;\n        my $str   = pack('B*', $ubits);\n        print $out_fh chr($rem);\n        print $out_fh mrl_compress_symbolic($str, \\&lzss_compress_symbolic);\n        print $out_fh create_huffman_entry($lengths);\n        print $out_fh create_huffman_entry($matches);\n        print $out_fh obh_encode($distances, \\&mrl_compress_symbolic);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        my $rem   = ord getc $fh;\n        my $str   = symbols2string(mrl_decompress_symbolic($fh, \\&lzss_decompress_symbolic));\n        my $ubits = unpack('B*', $str);\n        if ($rem != 0) {\n            $ubits = substr($ubits, 0, -(8 - $rem));\n        }\n        my $uncompressed = [unpack('C*', $ubits)];\n        my $lengths      = decode_huffman_entry($fh);\n        my $matches      = decode_huffman_entry($fh);\n        my $distances    = obh_decode($fh, \\&mrl_decompress_symbolic);\n        my $bits         = lz77_decode($uncompressed, $distances, $lengths, $matches);\n        print $out_fh symbols2string(decode_huffman_entry(pack('B*', $bits)));\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lz255_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# Edit: 01 September 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZSS compression + MRL + Huffman coding, using a maximum match distance of 255.\n\nuse 5.036;\n\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZ255',\n    VERSION => '0.01',\n    FORMAT  => 'lz255',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        local $Compression::Util::LZ_MAX_DIST = 255;\n        print $out_fh lzss_compress($chunk, \\&mrl_compress);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        print $out_fh lzss_decompress($fh, \\&mrl_decompress_symbolic);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lz2ss_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# Edit: 23 July 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression (LZ4-like) + LZSS compression.\n\nuse 5.036;\n\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZ2SS',\n    VERSION => '0.01',\n    FORMAT  => 'lz2ss',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh lz77_compress($chunk, sub ($s) { lzss_compress_symbolic($s, \\&mrl_compress_symbolic) });\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        print $out_fh lz77_decompress($fh, sub($s) { lzss_decompress_symbolic($s, \\&mrl_decompress_symbolic) });\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lz4_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Compress files using LZ4.\n\nuse 5.036;\nuse Getopt::Std        qw(getopts);\nuse File::Basename     qw(basename);\nuse Compress::LZ4Frame qw();\n\nuse constant {\n              PKGNAME => 'LZ4',\n              VERSION => '0.01',\n              FORMAT  => 'lz4',\n             };\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Compress data\n    print $out_fh Compress::LZ4Frame::compress(\n        do {\n            local $/;\n            <$fh>;\n        }\n    );\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    print $out_fh Compress::LZ4Frame::decompress(\n        do {\n            local $/;\n            <$fh>;\n        }\n    );\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lz772_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# Edit: 23 July 2024\n# https://github.com/trizen\n\n# Compress/decompress files using two rounds of LZ77 compression (LZ4-like).\n\nuse 5.036;\n\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZ772',\n    VERSION => '0.01',\n    FORMAT  => 'lz772',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh lz77_compress($chunk, sub($s) { lz77_compress_symbolic($s, \\&mrl_compress_symbolic) });\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        print $out_fh lz77_decompress($fh, sub($s) { lz77_decompress_symbolic($s, \\&mrl_decompress_symbolic) });\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lz77_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# Edit: 11 April 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + Huffman coding.\n\n# Encoding the distances/indices using a DEFLATE-like approach.\n\nuse 5.036;\n\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZ77',\n    VERSION => '0.01',\n    FORMAT  => 'lz77',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh lz77_compress($chunk);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        print $out_fh lz77_decompress($fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lz77f_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# Edit: 23 July 2024\n# https://github.com/trizen\n\n# Compress/decompress files using fast LZ77 compression + Huffman coding.\n\n# Encoding the distances/indices using a DEFLATE-like approach.\n\nuse 5.036;\n\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZ77F',\n    VERSION => '0.01',\n    FORMAT  => 'lz77f',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh lz77_compress($chunk, \\&create_huffman_entry, \\&lzss_encode_fast);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        print $out_fh lz77_decompress($fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzac_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# Edit: 11 April 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + Arithmetic Coding (in fixed bits).\n\n# Encoding the distances/indices using a DEFLATE-like approach.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n#\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZAC',\n    VERSION => '0.02',\n    FORMAT  => 'lzac',\n\n    CHUNK_SIZE => 1 << 16,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(2);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my ($uncompressed, $distances, $lengths, $matches) = lz77_encode($chunk);\n\n        my $est_ratio = length($chunk) / (4 * scalar(@$uncompressed));\n\n        say(scalar(@$uncompressed), ' -> ', $est_ratio);\n\n        print $out_fh mrl_compress_symbolic($uncompressed, \\&create_ac_entry);\n        print $out_fh create_ac_entry($lengths);\n        print $out_fh create_ac_entry($matches);\n        print $out_fh obh_encode($distances, \\&create_ac_entry);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my $uncompressed = mrl_decompress_symbolic($fh, \\&decode_ac_entry);\n        my $lengths      = decode_ac_entry($fh);\n        my $matches      = decode_ac_entry($fh);\n        my $distances    = obh_decode($fh, \\&decode_ac_entry);\n\n        print $out_fh lz77_decode($uncompressed, $distances, $lengths, $matches);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzb_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 10 May 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression (LZSS variant with hash tables), using a byte-aligned encoding, similar to LZ4.\n\n# References:\n#   https://github.com/lz4/lz4/blob/dev/doc/lz4_Frame_format.md\n#   https://github.com/lz4/lz4/blob/dev/doc/lz4_Block_format.md\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZB',\n    VERSION => '0.01',\n    FORMAT  => 'lzb',\n\n    CHUNK_SIZE => 1 << 18,\n};\n\nlocal $Compression::Util::LZ_MIN_LEN       = 4;                # minimum match length\nlocal $Compression::Util::LZ_MAX_LEN       = ~0;               # maximum match length\nlocal $Compression::Util::LZ_MAX_DIST      = (1 << 16) - 1;    # maximum match distance\nlocal $Compression::Util::LZ_MAX_CHAIN_LEN = 32;               # higher value = better compression\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh lzb_compress($chunk);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        print $out_fh lzb_decompress($fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzbbw_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# Edit: 04 June 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + Bzip2 + Huffman coding.\n\n# Encoding the distances/indices using a DEFLATE-like approach.\n\nuse 5.036;\n\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZBBW',\n    VERSION => '0.01',\n    FORMAT  => 'lzbbw',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my ($uncompressed, $distances, $lengths, $matches) = lz77_encode($chunk);\n        my $est_ratio = length($chunk) / (4 * scalar(@$uncompressed));\n        say(scalar(@$uncompressed), ' -> ', $est_ratio);\n\n        print $out_fh bwt_compress(symbols2string($uncompressed), sub($s) { lzss_compress_symbolic($s, \\&mrl_compress_symbolic) });\n        print $out_fh create_huffman_entry($lengths);\n        print $out_fh create_huffman_entry($matches);\n        print $out_fh obh_encode($distances, \\&mrl_compress_symbolic);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my $uncompressed = string2symbols(bwt_decompress($fh, sub($s) { lzss_decompress_symbolic($s, \\&mrl_decompress_symbolic) }));\n        my $lengths      = decode_huffman_entry($fh);\n        my $matches      = decode_huffman_entry($fh);\n        my $distances    = obh_decode($fh, \\&mrl_decompress_symbolic);\n\n        print $out_fh lz77_decode($uncompressed, $distances, $lengths, $matches);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzbf_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 10 May 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression (LZSS variant with hash tables -- fast variant), using a byte-aligned encoding, similar to LZ4.\n\n# References:\n#   https://github.com/lz4/lz4/blob/dev/doc/lz4_Frame_format.md\n#   https://github.com/lz4/lz4/blob/dev/doc/lz4_Block_format.md\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZBF',\n    VERSION => '0.01',\n    FORMAT  => 'lzbf',\n\n    CHUNK_SIZE => 1 << 18,\n};\n\nlocal $Compression::Util::LZ_MIN_LEN  = 5;                # minimum match length\nlocal $Compression::Util::LZ_MAX_LEN  = ~0;               # maximum match length\nlocal $Compression::Util::LZ_MAX_DIST = (1 << 16) - 1;    # maximum match distance\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh lzb_compress($chunk, \\&lzss_encode_fast);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        print $out_fh lzb_decompress($fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzbh_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 24 May 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression (LZSS variant with hash tables), using ideas from LZ4, combined with Huffman Coding.\n\n# References:\n#   https://github.com/lz4/lz4/blob/dev/doc/lz4_Frame_format.md\n#   https://github.com/lz4/lz4/blob/dev/doc/lz4_Block_format.md\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZBH',\n    VERSION => '0.01',\n    FORMAT  => 'lzbh',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\nlocal $Compression::Util::LZ_MIN_LEN       = 4;     # minimum match length\nlocal $Compression::Util::LZ_MAX_LEN       = ~0;    # maximum match length\nlocal $Compression::Util::LZ_MAX_CHAIN_LEN = 32;    # higher value = better compression\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub compression($chunk, $out_fh) {\n    my ($literals, $distances, $lengths) = lzss_encode($chunk);\n\n    my $literals_end = $#{$literals};\n    my @symbols;\n    my @len_symbols;\n    my @match_symbols;\n    my @dist_symbols;\n\n    for (my $i = 0 ; $i <= $literals_end ; ++$i) {\n\n        my $j = $i;\n        while ($i <= $literals_end and defined($literals->[$i])) {\n            ++$i;\n        }\n\n        my $literals_length = $i - $j;\n\n        my $dist      = $distances->[$i] // 0;\n        my $match_len = $lengths->[$i]   // 0;\n\n        my $len_byte = 0;\n\n        $len_byte |= ($literals_length >= 7 ? 7  : $literals_length) << 5;\n        $len_byte |= ($match_len >= 31      ? 31 : $match_len);\n\n        $literals_length -= 7;\n        $match_len       -= 31;\n\n        push @match_symbols, $len_byte;\n\n        while ($literals_length >= 0) {\n            push @len_symbols, ($literals_length >= 255 ? 255 : $literals_length);\n            $literals_length -= 255;\n        }\n        push @symbols, @{$literals}[$j .. $i - 1];\n\n        while ($match_len >= 0) {\n            push @match_symbols, ($match_len >= 255 ? 255 : $match_len);\n            $match_len -= 255;\n        }\n\n        push @dist_symbols, $dist;\n    }\n\n    print $out_fh create_huffman_entry(\\@symbols);\n    print $out_fh delta_encode(\\@len_symbols);\n    print $out_fh create_huffman_entry(\\@match_symbols);\n    print $out_fh obh_encode(\\@dist_symbols);\n}\n\nsub decompression($fh, $out_fh) {\n\n    my $data          = '';\n    my $symbols       = decode_huffman_entry($fh);\n    my $len_symbols   = delta_decode($fh);\n    my $match_symbols = decode_huffman_entry($fh);\n    my $dist_symbols  = obh_decode($fh);\n\n    while (@$symbols) {\n\n        my $len_byte = shift(@$match_symbols);\n\n        my $literals_length = $len_byte >> 5;\n        my $match_len       = $len_byte & 0b11111;\n\n        if ($literals_length == 7) {\n            while (1) {\n                my $byte_len = shift(@$len_symbols);\n                $literals_length += $byte_len;\n                last if $byte_len != 255;\n            }\n        }\n\n        my $literals = '';\n        if ($literals_length > 0) {\n            $literals = pack(\"C*\", splice(@$symbols, 0, $literals_length));\n        }\n\n        if ($match_len == 31) {\n            while (1) {\n                my $byte_len = shift(@$match_symbols);\n                $match_len += $byte_len;\n                last if $byte_len != 255;\n            }\n        }\n\n        my $offset = shift(@$dist_symbols);\n\n        $data .= $literals;\n\n        if ($offset == 1) {\n            $data .= substr($data, -1) x $match_len;\n        }\n        elsif ($offset >= $match_len) {\n            $data .= substr($data, length($data) - $offset, $match_len);\n        }\n        else {\n            foreach my $i (1 .. $match_len) {\n                $data .= substr($data, length($data) - $offset, 1);\n            }\n        }\n    }\n    print $out_fh $data;\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzbw2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 05 September 2023\n# Edit: 11 April 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + fixed-width integers encoding + Burrows-Wheeler Transform (BWT) + Huffman coding.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse List::Util        qw(uniq);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZBW2',\n    VERSION => '0.01',\n    FORMAT  => 'lzbw2',\n\n    COMPRESSED_BYTE   => chr(1),\n    UNCOMPRESSED_BYTE => chr(0),\n\n    CHUNK_SIZE => 1 << 16,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    my $lengths_str      = '';\n    my $matches_str      = '';\n    my $uncompressed_str = '';\n\n    my @sizes;\n    my @distances_block;\n\n    open my $uc_fh,    '>:raw', \\$uncompressed_str;\n    open my $len_fh,   '>:raw', \\$lengths_str;\n    open my $match_fh, '>:raw', \\$matches_str;\n\n    my $create_bz2_block = sub {\n\n        scalar(@sizes) > 0 or return;\n\n        print $out_fh delta_encode(\\@sizes);\n        print $out_fh bwt_compress($uncompressed_str, sub($s) { lzss_compress_symbolic($s, \\&mrl_compress_symbolic) });\n        print $out_fh bwt_compress($lengths_str);\n        print $out_fh bwt_compress($matches_str);\n\n        my $ratio = uniq(@distances_block) / @distances_block * 100;\n\n        say \"Dist ratio: $ratio\";\n\n        if ($ratio < 10) {\n            print $out_fh COMPRESSED_BYTE;\n            print $out_fh bwt_compress(symbols2string(\\@distances_block));\n        }\n        else {\n            print $out_fh UNCOMPRESSED_BYTE;\n            print $out_fh obh_encode(\\@distances_block);\n        }\n\n        @sizes           = ();\n        @distances_block = ();\n\n        open $uc_fh,    '>:raw', \\$uncompressed_str;\n        open $len_fh,   '>:raw', \\$lengths_str;\n        open $match_fh, '>:raw', \\$matches_str;\n    };\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        local $Compression::Util::LZ_MAX_DIST = 255;\n        my ($literals, $distances, $lengths, $matches) = lz77_encode($chunk);\n\n        my $est_ratio = length($chunk) / (4 * scalar(@$literals));\n        say \"Est. ratio: \", $est_ratio, \" (\", scalar(@$literals), \" uncompressed bytes)\";\n\n        push(@sizes, scalar(@$literals), scalar(@$distances), scalar(@$lengths), scalar(@$matches));\n        print $uc_fh pack('C*', @$literals);\n        print $len_fh pack('C*', @$lengths);\n        print $match_fh pack('C*', @$matches);\n        push @distances_block, @$distances;\n\n        if (length($uncompressed_str) >= CHUNK_SIZE) {\n            $create_bz2_block->();\n        }\n    }\n\n    $create_bz2_block->();\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my @sizes = @{delta_decode($fh)};\n\n        my @uncompressed = unpack('C*', bwt_decompress($fh, sub($s) { lzss_decompress_symbolic($s, \\&mrl_decompress_symbolic) }));\n        my @lengths      = unpack('C*', bwt_decompress($fh));\n        my @matches      = unpack('C*', bwt_decompress($fh));\n        my @distances    = @{(getc($fh) eq COMPRESSED_BYTE) ? bwt_decompress_symbolic($fh) : obh_decode($fh)};\n\n        while (@uncompressed) {\n\n            my $literals_size  = shift(@sizes) // die \"decompression error\";\n            my $distances_size = shift(@sizes) // die \"decompression error\";\n            my $lengths_size   = shift(@sizes) // die \"decompression error\";\n            my $matches_size   = shift(@sizes) // die \"decompression error\";\n\n            my @uncompressed_chunk = splice(@uncompressed, 0, $literals_size);\n            my @lengths_chunk      = splice(@lengths,      0, $lengths_size);\n            my @matches_chunk      = splice(@matches,      0, $matches_size);\n            my @distances_chunk    = splice(@distances,    0, $distances_size);\n\n            scalar(@uncompressed_chunk) == $literals_size or die \"decompression error\";\n            scalar(@lengths_chunk) == $lengths_size       or die \"decompression error\";\n            scalar(@matches_chunk) == $matches_size       or die \"decompression error\";\n            scalar(@distances_chunk) == $distances_size   or die \"decompression error\";\n\n            print $out_fh lz77_decode(\\@uncompressed_chunk, \\@distances_chunk, \\@lengths_chunk, \\@matches_chunk);\n        }\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzbw3_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 29 May 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + Bzip2, with maximum distance limited to 255.\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZBW3',\n    VERSION => '0.01',\n    FORMAT  => 'lzbw3',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(4);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        local $Compression::Util::LZ_MAX_DIST = 255;\n        my ($uncompressed, $distances, $lengths, $matches) = lz77_encode($chunk);\n\n        print $out_fh bwt_compress(symbols2string($uncompressed), sub($s) { lzss_compress_symbolic($s, \\&mrl_compress_symbolic) });\n        print $out_fh create_huffman_entry($lengths);\n        print $out_fh bwt_compress(symbols2string($matches));\n        print $out_fh bwt_compress(symbols2string($distances));\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my $uncompressed = bwt_decompress_symbolic($fh, sub($s) { lzss_decompress_symbolic($s, \\&mrl_decompress_symbolic) });\n        my $lengths      = decode_huffman_entry($fh);\n        my $matches      = bwt_decompress_symbolic($fh);\n        my $distances    = bwt_decompress_symbolic($fh);\n\n        print $out_fh lz77_decode($uncompressed, $distances, $lengths, $matches);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzbw4_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# Edit: 01 September 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + MRL + BWT + Huffman coding, using a maximum match distance of 255.\n\nuse 5.036;\n\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZBW4',\n    VERSION => '0.01',\n    FORMAT  => 'lzbw4',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my ($uncompressed, $distances, $lengths, $matches) = do {\n            local $Compression::Util::LZ_MAX_DIST = 255;\n            lz77_encode($chunk);\n        };\n        my $est_ratio = length($chunk) / (4 * scalar(@$uncompressed));\n        say(scalar(@$uncompressed), ' -> ', $est_ratio);\n\n        print $out_fh mrl_compress($uncompressed);\n        print $out_fh fibonacci_encode($lengths);\n        print $out_fh bwt_compress(symbols2string($matches));\n        print $out_fh bwt_compress(symbols2string($distances));\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my $uncompressed = mrl_decompress_symbolic($fh);\n        my $lengths      = fibonacci_decode($fh);\n        my $matches      = bwt_decompress_symbolic($fh);\n        my $distances    = bwt_decompress_symbolic($fh);\n\n        print $out_fh lz77_decode($uncompressed, $distances, $lengths, $matches);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzbw5_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# Edit: 04 September 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + MRL + Huffman coding.\n\n# Encoding the distances with BWT + Huffman coding and LZSS + MRL.\n\nuse 5.036;\n\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZBW5',\n    VERSION => '0.01',\n    FORMAT  => 'lzbw5',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my ($uncompressed, $distances, $lengths, $matches) = do {\n            local $Compression::Util::LZ_MAX_DIST = (1 << 16) - 1;\n            lz77_encode($chunk);\n        };\n        my $est_ratio = length($chunk) / (4 * scalar(@$uncompressed));\n        say(scalar(@$uncompressed), ' -> ', $est_ratio);\n\n        print $out_fh mrl_compress($uncompressed);\n        print $out_fh fibonacci_encode($lengths);\n        print $out_fh lzss_compress(symbols2string($matches));\n\n        my @byte0;\n        my @byte1;\n        foreach my $dist (@$distances) {\n            push @byte0, $dist >> 8;\n            push @byte1, $dist & 0xff;\n        }\n        print $out_fh bwt_compress(symbols2string(\\@byte0));\n        print $out_fh lzss_compress(symbols2string(\\@byte1), \\&mrl_compress_symbolic);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my $uncompressed = mrl_decompress_symbolic($fh);\n        my $lengths      = fibonacci_decode($fh);\n        my $matches      = lzss_decompress_symbolic($fh);\n\n        my $byte0 = bwt_decompress_symbolic($fh);\n        my $byte1 = lzss_decompress_symbolic($fh, \\&mrl_decompress_symbolic);\n\n        my @distances;\n        foreach my $i (0 .. $#$byte0) {\n            push @distances, ($byte0->[$i] << 8) | $byte1->[$i];\n        }\n\n        print $out_fh lz77_decode($uncompressed, \\@distances, $lengths, $matches);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzbw_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 05 September 2023\n# Edit: 11 April 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + fixed-width integers encoding + Burrows-Wheeler Transform (BWT) + Huffman coding.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZBW',\n    VERSION => '0.01',\n    FORMAT  => 'lzbw',\n\n    CHUNK_SIZE => 1 << 16,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    my $lengths_str      = '';\n    my $matches_str      = '';\n    my $uncompressed_str = '';\n\n    my @sizes;\n    my @distances_block;\n\n    open my $uc_fh,    '>:raw', \\$uncompressed_str;\n    open my $len_fh,   '>:raw', \\$lengths_str;\n    open my $match_fh, '>:raw', \\$matches_str;\n\n    my $create_bz2_block = sub {\n\n        scalar(@sizes) > 0 or return;\n\n        print $out_fh delta_encode(\\@sizes);\n        print $out_fh bwt_compress($uncompressed_str);\n        print $out_fh bwt_compress($lengths_str);\n        print $out_fh bwt_compress($matches_str);\n        print $out_fh bwt_compress(symbols2string(\\@distances_block));\n\n        @sizes           = ();\n        @distances_block = ();\n\n        open $uc_fh,    '>:raw', \\$uncompressed_str;\n        open $len_fh,   '>:raw', \\$lengths_str;\n        open $match_fh, '>:raw', \\$matches_str;\n    };\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        local $Compression::Util::LZ_MAX_DIST = 255;\n        my ($literals, $distances, $lengths, $matches) = lz77_encode($chunk);\n\n        my $est_ratio = length($chunk) / (4 * scalar(@$literals));\n        say \"Est. ratio: \", $est_ratio, \" (\", scalar(@$literals), \" uncompressed bytes)\";\n\n        push(@sizes, scalar(@$literals), scalar(@$distances), scalar(@$lengths), scalar(@$matches));\n        print $uc_fh pack('C*', @$literals);\n        print $len_fh pack('C*', @$lengths);\n        print $match_fh pack('C*', @$matches);\n        push @distances_block, @$distances;\n\n        if (length($uncompressed_str) >= CHUNK_SIZE) {\n            $create_bz2_block->();\n        }\n    }\n\n    $create_bz2_block->();\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my @sizes = @{delta_decode($fh)};\n\n        my @uncompressed = unpack('C*', bwt_decompress($fh));\n        my @lengths      = unpack('C*', bwt_decompress($fh));\n        my @matches      = unpack('C*', bwt_decompress($fh));\n        my @distances    = unpack('C*', bwt_decompress($fh));\n\n        while (@uncompressed) {\n\n            my $literals_size  = shift(@sizes) // die \"decompression error\";\n            my $distances_size = shift(@sizes) // die \"decompression error\";\n            my $lengths_size   = shift(@sizes) // die \"decompression error\";\n            my $matches_size   = shift(@sizes) // die \"decompression error\";\n\n            my @uncompressed_chunk = splice(@uncompressed, 0, $literals_size);\n            my @lengths_chunk      = splice(@lengths,      0, $lengths_size);\n            my @matches_chunk      = splice(@matches,      0, $matches_size);\n            my @distances_chunk    = splice(@distances,    0, $distances_size);\n\n            scalar(@uncompressed_chunk) == $literals_size or die \"decompression error\";\n            scalar(@lengths_chunk) == $lengths_size       or die \"decompression error\";\n            scalar(@matches_chunk) == $matches_size       or die \"decompression error\";\n            scalar(@distances_chunk) == $distances_size   or die \"decompression error\";\n\n            print $out_fh lz77_decode(\\@uncompressed_chunk, \\@distances_chunk, \\@lengths_chunk, \\@matches_chunk);\n        }\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzbwa_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 05 September 2023\n# Edit: 11 April 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + fixed-width integers encoding + Burrows-Wheeler Transform (BWT) + Arithmetic Coding.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n#\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZBWA',\n    VERSION => '0.01',\n    FORMAT  => 'lzbwa',\n\n    CHUNK_SIZE => 1 << 16,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    my $lengths_str      = '';\n    my $matches_str      = '';\n    my $uncompressed_str = '';\n\n    my @sizes;\n    my @distances_block;\n\n    open my $uc_fh,    '>:raw', \\$uncompressed_str;\n    open my $len_fh,   '>:raw', \\$lengths_str;\n    open my $match_fh, '>:raw', \\$matches_str;\n\n    my $create_bz2_block = sub {\n\n        scalar(@sizes) > 0 or return;\n\n        print $out_fh delta_encode(\\@sizes);\n        print $out_fh bwt_compress(\n            $uncompressed_str,\n            sub ($s) {\n                lzss_compress_symbolic($s, sub ($s) { mrl_compress_symbolic($s, \\&create_ac_entry) });\n            }\n        );\n        print $out_fh bwt_compress($lengths_str,                      \\&create_ac_entry);\n        print $out_fh bwt_compress($matches_str,                      \\&create_ac_entry);\n        print $out_fh bwt_compress(symbols2string(\\@distances_block), \\&create_ac_entry);\n\n        @sizes           = ();\n        @distances_block = ();\n\n        open $uc_fh,    '>:raw', \\$uncompressed_str;\n        open $len_fh,   '>:raw', \\$lengths_str;\n        open $match_fh, '>:raw', \\$matches_str;\n    };\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        local $Compression::Util::LZ_MAX_DIST = 255;\n        my ($literals, $distances, $lengths, $matches) = lz77_encode($chunk);\n\n        my $est_ratio = length($chunk) / (4 * scalar(@$literals));\n        say \"Est. ratio: \", $est_ratio, \" (\", scalar(@$literals), \" uncompressed bytes)\";\n\n        push(@sizes, scalar(@$literals), scalar(@$distances), scalar(@$lengths), scalar(@$matches));\n        print $uc_fh pack('C*', @$literals);\n        print $len_fh pack('C*', @$lengths);\n        print $match_fh pack('C*', @$matches);\n        push @distances_block, @$distances;\n\n        if (length($uncompressed_str) >= CHUNK_SIZE) {\n            $create_bz2_block->();\n        }\n    }\n\n    $create_bz2_block->();\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my @sizes = @{delta_decode($fh)};\n\n        my @uncompressed = unpack(\n            'C*',\n            bwt_decompress(\n                $fh,\n                sub ($s) {\n                    lzss_decompress_symbolic($s, sub ($s) { mrl_decompress_symbolic($s, \\&decode_ac_entry) });\n                }\n            )\n        );\n        my @lengths   = unpack('C*', bwt_decompress($fh, \\&decode_ac_entry));\n        my @matches   = unpack('C*', bwt_decompress($fh, \\&decode_ac_entry));\n        my @distances = unpack('C*', bwt_decompress($fh, \\&decode_ac_entry));\n\n        while (@uncompressed) {\n\n            my $literals_size  = shift(@sizes) // die \"decompression error\";\n            my $distances_size = shift(@sizes) // die \"decompression error\";\n            my $lengths_size   = shift(@sizes) // die \"decompression error\";\n            my $matches_size   = shift(@sizes) // die \"decompression error\";\n\n            my @uncompressed_chunk = splice(@uncompressed, 0, $literals_size);\n            my @lengths_chunk      = splice(@lengths,      0, $lengths_size);\n            my @matches_chunk      = splice(@matches,      0, $matches_size);\n            my @distances_chunk    = splice(@distances,    0, $distances_size);\n\n            scalar(@uncompressed_chunk) == $literals_size or die \"decompression error\";\n            scalar(@lengths_chunk) == $lengths_size       or die \"decompression error\";\n            scalar(@matches_chunk) == $matches_size       or die \"decompression error\";\n            scalar(@distances_chunk) == $distances_size   or die \"decompression error\";\n\n            print $out_fh lz77_decode(\\@uncompressed_chunk, \\@distances_chunk, \\@lengths_chunk, \\@matches_chunk);\n        }\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzbwad_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 05 September 2023\n# Edit: 11 April 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + fixed-width integers encoding + Burrows-Wheeler Transform (BWT) + Adaptive Arithmetic Coding.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n#\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZBWAD',\n    VERSION => '0.01',\n    FORMAT  => 'lzbwad',\n\n    CHUNK_SIZE => 1 << 16,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    my $lengths_str      = '';\n    my $matches_str      = '';\n    my $uncompressed_str = '';\n\n    my @sizes;\n    my @distances_block;\n\n    open my $uc_fh,    '>:raw', \\$uncompressed_str;\n    open my $len_fh,   '>:raw', \\$lengths_str;\n    open my $match_fh, '>:raw', \\$matches_str;\n\n    my $create_bz2_block = sub {\n\n        scalar(@sizes) > 0 or return;\n\n        print $out_fh delta_encode(\\@sizes);\n        print $out_fh bwt_compress(\n            $uncompressed_str,\n            sub ($s) {\n                lzss_compress_symbolic($s, sub ($s) { mrl_compress_symbolic($s, \\&create_adaptive_ac_entry) });\n            }\n        );\n        print $out_fh bwt_compress($lengths_str,                      \\&create_adaptive_ac_entry);\n        print $out_fh bwt_compress($matches_str,                      \\&create_adaptive_ac_entry);\n        print $out_fh bwt_compress(symbols2string(\\@distances_block), \\&create_adaptive_ac_entry);\n\n        @sizes           = ();\n        @distances_block = ();\n\n        open $uc_fh,    '>:raw', \\$uncompressed_str;\n        open $len_fh,   '>:raw', \\$lengths_str;\n        open $match_fh, '>:raw', \\$matches_str;\n    };\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        local $Compression::Util::LZ_MAX_DIST = 255;\n        my ($literals, $distances, $lengths, $matches) = lz77_encode($chunk);\n\n        my $est_ratio = length($chunk) / (4 * scalar(@$literals));\n        say \"Est. ratio: \", $est_ratio, \" (\", scalar(@$literals), \" uncompressed bytes)\";\n\n        push(@sizes, scalar(@$literals), scalar(@$distances), scalar(@$lengths), scalar(@$matches));\n        print $uc_fh pack('C*', @$literals);\n        print $len_fh pack('C*', @$lengths);\n        print $match_fh pack('C*', @$matches);\n        push @distances_block, @$distances;\n\n        if (length($uncompressed_str) >= CHUNK_SIZE) {\n            $create_bz2_block->();\n        }\n    }\n\n    $create_bz2_block->();\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my @sizes = @{delta_decode($fh)};\n\n        my @uncompressed = unpack(\n            'C*',\n            bwt_decompress(\n                $fh,\n                sub ($s) {\n                    lzss_decompress_symbolic($s, sub ($s) { mrl_decompress_symbolic($s, \\&decode_adaptive_ac_entry) });\n                }\n            )\n        );\n        my @lengths   = unpack('C*', bwt_decompress($fh, \\&decode_adaptive_ac_entry));\n        my @matches   = unpack('C*', bwt_decompress($fh, \\&decode_adaptive_ac_entry));\n        my @distances = unpack('C*', bwt_decompress($fh, \\&decode_adaptive_ac_entry));\n\n        while (@uncompressed) {\n\n            my $literals_size  = shift(@sizes) // die \"decompression error\";\n            my $distances_size = shift(@sizes) // die \"decompression error\";\n            my $lengths_size   = shift(@sizes) // die \"decompression error\";\n            my $matches_size   = shift(@sizes) // die \"decompression error\";\n\n            my @uncompressed_chunk = splice(@uncompressed, 0, $literals_size);\n            my @lengths_chunk      = splice(@lengths,      0, $lengths_size);\n            my @matches_chunk      = splice(@matches,      0, $matches_size);\n            my @distances_chunk    = splice(@distances,    0, $distances_size);\n\n            scalar(@uncompressed_chunk) == $literals_size or die \"decompression error\";\n            scalar(@lengths_chunk) == $lengths_size       or die \"decompression error\";\n            scalar(@matches_chunk) == $matches_size       or die \"decompression error\";\n            scalar(@distances_chunk) == $distances_size   or die \"decompression error\";\n\n            print $out_fh lz77_decode(\\@uncompressed_chunk, \\@distances_chunk, \\@lengths_chunk, \\@matches_chunk);\n        }\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzbwd_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 07 September 2023\n# Edit: 11 April 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + DEFLATE integers encoding + Burrows-Wheeler Transform (BWT) + Huffman coding.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n#\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZBWD',\n    VERSION => '0.01',\n    FORMAT  => 'lzbwd',\n\n    CHUNK_SIZE => 1 << 16,                  # higher value = better compression\n    MAX_INT    => oct('0b' . ('1' x 32)),\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\n# [distance value, offset bits]\nmy @DISTANCE_SYMBOLS = (map { [$_, 0] } 0 .. 4);\n\nuntil ($DISTANCE_SYMBOLS[-1][0] > MAX_INT) {\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n}\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub encode_integers ($integers) {\n\n    my @symbols;\n    my $offset_bits = '';\n\n    foreach my $dist (@$integers) {\n        foreach my $i (0 .. $#DISTANCE_SYMBOLS) {\n            if ($DISTANCE_SYMBOLS[$i][0] > $dist) {\n                push @symbols, $i - 1;\n                if ($DISTANCE_SYMBOLS[$i - 1][1] > 0) {\n                    $offset_bits .= sprintf('%0*b', $DISTANCE_SYMBOLS[$i - 1][1], $dist - $DISTANCE_SYMBOLS[$i - 1][0]);\n                }\n                last;\n            }\n        }\n    }\n\n    return (pack('C*', @symbols), pack('B*', $offset_bits));\n}\n\nsub decode_integers ($symbols, $fh) {\n\n    my $bits_len = 0;\n\n    foreach my $i (@$symbols) {\n        $bits_len += $DISTANCE_SYMBOLS[$i][1];\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @distances;\n    foreach my $i (@$symbols) {\n        push @distances, $DISTANCE_SYMBOLS[$i][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$i][1], ''));\n    }\n\n    return \\@distances;\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    my $lengths_str      = '';\n    my $matches_str      = '';\n    my $uncompressed_str = '';\n\n    my @sizes;\n    my @distances_chunk;\n\n    open my $uc_fh,    '>:raw', \\$uncompressed_str;\n    open my $len_fh,   '>:raw', \\$lengths_str;\n    open my $match_fh, '>:raw', \\$matches_str;\n\n    my $create_bz2_block = sub {\n\n        scalar(@sizes) > 0 or return;\n\n        print $out_fh delta_encode(\\@sizes);\n        print $out_fh bwt_compress($uncompressed_str, sub($s) { lzss_compress_symbolic($s, \\&mrl_compress_symbolic) });\n        print $out_fh bwt_compress($lengths_str);\n        print $out_fh bwt_compress($matches_str);\n        print $out_fh bwt_compress(symbols2string(\\@distances_chunk));\n\n        @sizes           = ();\n        @distances_chunk = ();\n\n        open $uc_fh,    '>:raw', \\$uncompressed_str;\n        open $len_fh,   '>:raw', \\$lengths_str;\n        open $match_fh, '>:raw', \\$matches_str;\n    };\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        local $Compression::Util::LZ_MAX_DIST = 255;\n        my ($literals, $distances, $lengths, $matches) = lz77_encode($chunk);\n\n        my $est_ratio = length($chunk) / (4 * scalar(@$literals));\n        say \"Est. ratio: \", $est_ratio, \" (\", scalar(@$literals), \" uncompressed bytes)\";\n\n        push(@sizes, scalar(@$literals), scalar(@$distances), scalar(@$lengths), scalar(@$matches));\n        print $uc_fh pack('C*', @$literals);\n        print $len_fh pack('C*', @$lengths);\n        print $match_fh pack('C*', @$matches);\n        push @distances_chunk, @$distances;\n\n        if (length($uncompressed_str) >= CHUNK_SIZE) {\n            $create_bz2_block->();\n        }\n    }\n\n    $create_bz2_block->();\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my @sizes = @{delta_decode($fh)};\n\n        my @uncompressed = unpack('C*', bwt_decompress($fh, sub($s) { lzss_decompress_symbolic($s, \\&mrl_decompress_symbolic) }));\n        my @lengths      = unpack('C*', bwt_decompress($fh));\n        my @matches      = unpack('C*', bwt_decompress($fh));\n        my @distances    = unpack('C*', bwt_decompress($fh));\n\n        while (@uncompressed) {\n\n            my $literals_size  = shift(@sizes) // die \"decompression error\";\n            my $distances_size = shift(@sizes) // die \"decompression error\";\n            my $lengths_size   = shift(@sizes) // die \"decompression error\";\n            my $matches_size   = shift(@sizes) // die \"decompression error\";\n\n            my @uncompressed_chunk = splice(@uncompressed, 0, $literals_size);\n            my @lengths_chunk      = splice(@lengths,      0, $lengths_size);\n            my @matches_chunk      = splice(@matches,      0, $matches_size);\n            my @distances_chunk    = splice(@distances,    0, $distances_size);\n\n            scalar(@uncompressed_chunk) == $literals_size or die \"decompression error\";\n            scalar(@lengths_chunk) == $lengths_size       or die \"decompression error\";\n            scalar(@matches_chunk) == $matches_size       or die \"decompression error\";\n            scalar(@distances_chunk) == $distances_size   or die \"decompression error\";\n\n            print $out_fh lz77_decode(\\@uncompressed_chunk, \\@distances_chunk, \\@lengths_chunk, \\@matches_chunk);\n        }\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzbwh_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 07 September 2023\n# Edit: 11 April 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + DEFLATE integers encoding + Burrows-Wheeler Transform (BWT) + Huffman coding.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n#\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZBWH',\n    VERSION => '0.01',\n    FORMAT  => 'lzbwh',\n\n    CHUNK_SIZE => 1 << 16,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    my $lengths_str      = '';\n    my $matches_str      = '';\n    my $uncompressed_str = '';\n\n    my @sizes;\n    my @distances_block;\n\n    open my $uc_fh,    '>:raw', \\$uncompressed_str;\n    open my $len_fh,   '>:raw', \\$lengths_str;\n    open my $match_fh, '>:raw', \\$matches_str;\n\n    my $create_bz2_block = sub {\n\n        scalar(@sizes) > 0 or return;\n\n        print $out_fh delta_encode(\\@sizes);\n        print $out_fh bwt_compress($uncompressed_str, sub ($s) { lzss_compress_symbolic($s, \\&mrl_compress_symbolic) });\n        print $out_fh bwt_compress($lengths_str);\n        print $out_fh bwt_compress($matches_str);\n        print $out_fh bwt_compress(symbols2string(\\@distances_block));\n\n        @sizes           = ();\n        @distances_block = ();\n\n        open $uc_fh,    '>:raw', \\$uncompressed_str;\n        open $len_fh,   '>:raw', \\$lengths_str;\n        open $match_fh, '>:raw', \\$matches_str;\n    };\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        local $Compression::Util::LZ_MAX_DIST = 255;\n        my ($literals, $distances, $lengths, $matches) = lz77_encode($chunk);\n\n        my $est_ratio = length($chunk) / (4 * scalar(@$literals));\n        say \"Est. ratio: \", $est_ratio, \" (\", scalar(@$literals), \" uncompressed bytes)\";\n\n        push(@sizes, scalar(@$literals), scalar(@$distances), scalar(@$lengths), scalar(@$matches));\n        print $uc_fh pack('C*', @$literals);\n        print $len_fh pack('C*', @$lengths);\n        print $match_fh pack('C*', @$matches);\n        push @distances_block, @$distances;\n\n        if (length($uncompressed_str) >= CHUNK_SIZE) {\n            $create_bz2_block->();\n        }\n    }\n\n    $create_bz2_block->();\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my @sizes = @{delta_decode($fh)};\n\n        my @uncompressed = unpack('C*', bwt_decompress($fh, sub($s) { lzss_decompress_symbolic($s, \\&mrl_decompress_symbolic) }));\n        my @lengths      = unpack('C*', bwt_decompress($fh));\n        my @matches      = unpack('C*', bwt_decompress($fh));\n        my @distances    = unpack('C*', bwt_decompress($fh));\n\n        while (@uncompressed) {\n\n            my $literals_size  = shift(@sizes) // die \"decompression error\";\n            my $distances_size = shift(@sizes) // die \"decompression error\";\n            my $lengths_size   = shift(@sizes) // die \"decompression error\";\n            my $matches_size   = shift(@sizes) // die \"decompression error\";\n\n            my @uncompressed_chunk = splice(@uncompressed, 0, $literals_size);\n            my @lengths_chunk      = splice(@lengths,      0, $lengths_size);\n            my @matches_chunk      = splice(@matches,      0, $matches_size);\n            my @distances_chunk    = splice(@distances,    0, $distances_size);\n\n            scalar(@uncompressed_chunk) == $literals_size or die \"decompression error\";\n            scalar(@lengths_chunk) == $lengths_size       or die \"decompression error\";\n            scalar(@matches_chunk) == $matches_size       or die \"decompression error\";\n            scalar(@distances_chunk) == $distances_size   or die \"decompression error\";\n\n            print $out_fh lz77_decode(\\@uncompressed_chunk, \\@distances_chunk, \\@lengths_chunk, \\@matches_chunk);\n        }\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzbws_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# Edit: 25 July 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + symbolic Bzip2 (MRL variant).\n\nuse 5.036;\n\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZBWS',\n    VERSION => '0.01',\n    FORMAT  => 'lzbws',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh lz77_compress($chunk, \\&mrl_compress_symbolic);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        print $out_fh lz77_decompress($fh, \\&mrl_decompress_symbolic);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzhd2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# Edit: 01 September 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + MRL + Huffman coding.\n\n# Encoding the distances/indices using a DEFLATE-like approach + MRL compression.\n\nuse 5.036;\n\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZHD2',\n    VERSION => '0.01',\n    FORMAT  => 'lzhd2',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my ($uncompressed, $distances, $lengths, $matches) = lz77_encode($chunk);\n        my $est_ratio = length($chunk) / (4 * scalar(@$uncompressed));\n        say(scalar(@$uncompressed), ' -> ', $est_ratio);\n\n        print $out_fh mrl_compress($uncompressed);\n        print $out_fh fibonacci_encode($lengths);\n        print $out_fh lzss_compress(symbols2string($matches));\n        print $out_fh obh_encode($distances, \\&mrl_compress);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my $uncompressed = mrl_decompress_symbolic($fh);\n        my $lengths      = fibonacci_decode($fh);\n        my $matches      = lzss_decompress_symbolic($fh);\n        my $distances    = obh_decode($fh, \\&mrl_decompress_symbolic);\n\n        print $out_fh lz77_decode($uncompressed, $distances, $lengths, $matches);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzhd_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# Edit: 11 April 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + Huffman coding.\n\n# Encoding the distances/indices using a DEFLATE-like approach.\n\nuse 5.036;\n\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZHD',\n    VERSION => '0.02',\n    FORMAT  => 'lzhd',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(2);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my ($uncompressed, $distances, $lengths, $matches) = lz77_encode($chunk);\n        my $est_ratio = length($chunk) / (4 * scalar(@$uncompressed));\n        say(scalar(@$uncompressed), ' -> ', $est_ratio);\n\n        print $out_fh mrl_compress_symbolic($uncompressed);\n        print $out_fh fibonacci_encode($lengths);\n        print $out_fh create_huffman_entry($matches);\n        print $out_fh obh_encode($distances);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my $uncompressed = mrl_decompress_symbolic($fh);\n        my $lengths      = fibonacci_decode($fh);\n        my $matches      = decode_huffman_entry($fh);\n        my $distances    = obh_decode($fh);\n\n        print $out_fh lz77_decode($uncompressed, $distances, $lengths, $matches);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzih_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# Edit: 13 June 2023\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + fixed-width integers encoding + Huffman coding.\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZIH',\n    VERSION => '0.04',\n    FORMAT  => 'lzih',\n\n    CHUNK_SIZE => 1 << 16,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(4);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my ($uncompressed, $distances, $lengths, $matches) = lz77_encode($chunk);\n\n        my $est_ratio = length($chunk) / (4 * scalar(@$uncompressed));\n        say(scalar(@$uncompressed), ' -> ', $est_ratio);\n\n        print $out_fh mrl_compress_symbolic($uncompressed);\n        print $out_fh create_huffman_entry($lengths);\n        print $out_fh create_huffman_entry($matches);\n        print $out_fh abc_encode($distances);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my $uncompressed = mrl_decompress_symbolic($fh);\n        my $lengths      = decode_huffman_entry($fh);\n        my $matches      = decode_huffman_entry($fh);\n        my $distances    = abc_decode($fh);\n\n        print $out_fh lz77_decode($uncompressed, $distances, $lengths, $matches);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzmrl2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# Edit: 25 July 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + Move to front + RLE + Huffman coding.\n\nuse 5.036;\n\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZMRL2',\n    VERSION => '0.01',\n    FORMAT  => 'lzmrl2',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my ($uncompressed, $distances, $lengths, $matches) = lz77_encode($chunk);\n        my $est_ratio = length($chunk) / (4 * scalar(@$uncompressed));\n        say(scalar(@$uncompressed), ' -> ', $est_ratio);\n\n        print $out_fh mrl_compress_symbolic($uncompressed);\n        print $out_fh create_huffman_entry($lengths);\n        print $out_fh create_huffman_entry($matches);\n        print $out_fh obh_encode($distances, \\&mrl_compress_symbolic);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my $uncompressed = mrl_decompress_symbolic($fh);\n        my $lengths      = decode_huffman_entry($fh);\n        my $matches      = decode_huffman_entry($fh);\n        my $distances    = obh_decode($fh, \\&mrl_decompress_symbolic);\n\n        print $out_fh lz77_decode($uncompressed, $distances, $lengths, $matches);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzmrl_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# Edit: 23 July 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + Move-to-front + RLE + Huffman coding.\n\nuse 5.036;\n\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZMRL',\n    VERSION => '0.01',\n    FORMAT  => 'lzmrl',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh lz77_compress($chunk, \\&mrl_compress_symbolic);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        print $out_fh lz77_decompress($fh, \\&mrl_decompress_symbolic);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzop_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Compress files using Lzop.\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\n\nuse IO::Compress::Lzop     qw(lzop);\nuse IO::Uncompress::UnLzop qw(unlzop);\n\nuse constant {\n              PKGNAME => 'LZOP',\n              VERSION => '0.01',\n              FORMAT  => 'lzo',\n             };\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Compress data\n    lzop($fh, $out_fh) or die \"compression error\";\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    unlzop($fh, $out_fh) or die \"decompression error\";\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzsbw_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 June 2023\n# Edit: 11 April 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZSS + Bzip2 (MRL variant).\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZSBW',\n    VERSION => '0.01',\n    FORMAT  => 'lzsbw',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my ($literals, $distances, $lengths) = lzss_encode($chunk);\n        my $est_ratio = length($chunk) / (scalar(@$literals) + scalar(@$lengths) + 2 * scalar(@$distances));\n        say scalar(@$literals), ' -> ', $est_ratio;\n\n        print $out_fh deflate_encode($literals, $distances, $lengths, \\&mrl_compress_symbolic);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        my ($literals, $distances, $lengths) = deflate_decode($fh, \\&mrl_decompress_symbolic);\n        print $out_fh lzss_decode($literals, $distances, $lengths);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzss2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 June 2023\n# Edit: 23 July 2024\n# https://github.com/trizen\n\n# Compress/decompress files using two rounds of LZ77 compression (LZSS variant).\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZSSM',\n    VERSION => '0.01',\n    FORMAT  => 'lzssm',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\nlocal $Compression::Util::LZ_MIN_LEN       = 4;          # minimum match length\nlocal $Compression::Util::LZ_MAX_LEN       = 1 << 15;    # maximum match length\nlocal $Compression::Util::LZ_MAX_CHAIN_LEN = 64;         # higher value = better compression\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh lzss_compress($chunk, sub($s) { lzss_compress_symbolic($s, \\&mrl_compress_symbolic) });\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        print $out_fh lzss_decompress($fh, sub($s) { lzss_decompress_symbolic($s, \\&mrl_decompress_symbolic) });\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzss77_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 June 2023\n# Edit: 23 July 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression (LZSS variant) + LZ77 compression.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZSSM',\n    VERSION => '0.01',\n    FORMAT  => 'lzssm',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\nlocal $Compression::Util::LZ_MIN_LEN       = 4;          # minimum match length\nlocal $Compression::Util::LZ_MAX_LEN       = 1 << 15;    # maximum match length\nlocal $Compression::Util::LZ_MAX_CHAIN_LEN = 64;         # higher value = better compression\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh lzss_compress($chunk, sub($s) { lz77_compress_symbolic($s, \\&mrl_compress_symbolic) });\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        print $out_fh lzss_decompress($fh, sub($s) { lz77_decompress_symbolic($s, \\&mrl_decompress_symbolic) });\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzss_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 June 2023\n# Edit: 21 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression (LZSS variant) + Huffman coding.\n\n# Encoding the literals and the pointers using a DEFLATE-like approach.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZSS',\n    VERSION => '0.01',\n    FORMAT  => 'lzss',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\nlocal $Compression::Util::LZ_MIN_LEN       = 4;          # minimum match length\nlocal $Compression::Util::LZ_MAX_LEN       = 1 << 15;    # maximum match length\nlocal $Compression::Util::LZ_MAX_CHAIN_LEN = 64;         # higher value = better compression\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh lzss_compress($chunk);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        print $out_fh lzss_decompress($fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzssf_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 June 2023\n# Edit: 21 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression (LZSS variant with hash tables -- fast version) + Huffman coding.\n\n# Encoding the literals and the pointers using a DEFLATE-like approach.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZSSF',\n    VERSION => '0.01',\n    FORMAT  => 'lzssf',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\nlocal $Compression::Util::LZ_MIN_LEN = 5;          # minimum match length\nlocal $Compression::Util::LZ_MAX_LEN = 1 << 15;    # maximum match length\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh lzss_compress($chunk, \\&create_huffman_entry, \\&lzss_encode_fast);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        print $out_fh lzss_decompress($fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzssm_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 June 2023\n# Edit: 23 July 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression (LZSS variant) + Move-to-front + RLE + Huffman coding.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZSSM',\n    VERSION => '0.01',\n    FORMAT  => 'lzssm',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\nlocal $Compression::Util::LZ_MIN_LEN       = 4;          # minimum match length\nlocal $Compression::Util::LZ_MAX_LEN       = 1 << 15;    # maximum match length\nlocal $Compression::Util::LZ_MAX_CHAIN_LEN = 64;         # higher value = better compression\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh lzss_compress($chunk, \\&mrl_compress_symbolic);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        print $out_fh lzss_decompress($fh, \\&mrl_decompress_symbolic);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/lzw_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 08 December 2022\n# Edit: 15 June 2023\n# https://github.com/trizen\n\n# Compress/decompress files using LZW compression.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Lempel%E2%80%93Ziv%E2%80%93Welch\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'LZW',\n    VERSION => '0.03',\n    FORMAT  => 'lzw',\n\n    CHUNK_SIZE => 1 << 17,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(3);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh lzw_compress($chunk);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        print $out_fh lzw_decompress($fh);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/mblz_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 June 2023\n# Edit: 31 July 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Move-to-front + Adaptive Binary Coding, followed by LZ77 compression (LZ4-like) on bits + Bzip2 on the literals.\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'MBLZ',\n    VERSION => '0.01',\n    FORMAT  => 'mblz',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\nlocal $Compression::Util::LZ_MIN_LEN       = 8 * 4;      # minimum match length\nlocal $Compression::Util::LZ_MAX_LEN       = 1 << 15;    # maximum match length\nlocal $Compression::Util::LZ_MAX_CHAIN_LEN = 64;         # higher value = better compression\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        my $bits = unpack('B*', mrl_compress_symbolic(string2symbols($chunk)));\n        my ($uncompressed, $lengths, $matches, $distances) = lz77_encode($bits);\n        my $ubits = pack('C*', @$uncompressed);\n        my $rem   = length($ubits) % 8;\n        my $str   = pack('B*', $ubits);\n        print $out_fh chr($rem);\n        print $out_fh bwt_compress($str);\n        print $out_fh create_huffman_entry($lengths);\n        print $out_fh create_huffman_entry($matches);\n        print $out_fh obh_encode($distances, \\&mrl_compress_symbolic);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        my $rem   = ord getc $fh;\n        my $str   = bwt_decompress($fh);\n        my $ubits = unpack('B*', $str);\n        if ($rem != 0) {\n            $ubits = substr($ubits, 0, -(8 - $rem));\n        }\n        my $uncompressed = [unpack('C*', $ubits)];\n        my $lengths      = decode_huffman_entry($fh);\n        my $matches      = decode_huffman_entry($fh);\n        my $distances    = obh_decode($fh, \\&mrl_decompress_symbolic);\n        my $bits         = lz77_decode($uncompressed, $lengths, $matches, $distances);\n        print $out_fh symbols2string(mrl_decompress_symbolic(pack('B*', $bits)));\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/mbwr_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 14 June 2023\n# Edit: 13 April 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Move-to-Front Transform (MTF) + Burrows-Wheeler Transform (BWT) + Run-length encoding (RLE) + Huffman coding.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'MBWR',\n    VERSION => '0.01',\n    FORMAT  => 'mbwr',\n\n    CHUNK_SIZE => 1 << 17,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub compression ($chunk, $out_fh) {\n    my ($mtf, $alphabet) = mtf_encode($chunk);\n    print $out_fh encode_alphabet($alphabet);\n    print $out_fh bwt_compress(symbols2string($mtf));\n}\n\nsub decompression ($fh, $out_fh) {\n    my $alphabet = decode_alphabet($fh);\n    my $mtf      = string2symbols(bwt_decompress($fh));\n    my $data     = mtf_decode($mtf, $alphabet);\n    print $out_fh symbols2string($data);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/mrl_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 05 August 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Move-to-front + RLE + Huffman coding.\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'MRL',\n    VERSION => '0.01',\n    FORMAT  => 'mrl',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh mrl_compress($chunk);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        print $out_fh mrl_decompress($fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/mybzip2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Edit: 21 August 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Bzip2 from Compression::Util.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std             qw(getopts);\nuse File::Basename          qw(basename);\nuse Compression::Util       qw(:all);\nuse IO::Uncompress::Bunzip2 qw(bunzip2);\n\nuse constant {\n              PKGNAME => 'BZIP2',\n              VERSION => '0.01',\n              FORMAT  => 'bz2',\n             };\n\nsub usage ($code = 0) {\n\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Compress data\n    print $out_fh bzip2_compress($fh);\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    my $enc = do {\n        local $/;\n        <$fh>;\n    };\n\n    my $dec = bzip2_decompress($enc);\n\n    bunzip2(\\$enc, \\my $dec2) or die \"decompression error\";\n\n    if ($dec ne $dec2) {\n        die \"Failed to decompress correctly\";\n    }\n\n    print $out_fh $dec;\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/mygzip_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Edit: 22 August 2024\n# https://github.com/trizen\n\n# Compress/decompress files using GZIP from Compression::Util.\n\nuse 5.036;\nuse Getopt::Std            qw(getopts);\nuse File::Basename         qw(basename);\nuse Compression::Util      qw(:all);\nuse IO::Uncompress::Gunzip qw(gunzip);\n\nuse constant {\n              PKGNAME => 'GZIP',\n              VERSION => '0.01',\n              FORMAT  => 'gz',\n             };\n\nsub usage($code = 0) {\n\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Compress data\n    print $out_fh gzip_compress($fh);\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    my $enc = do {\n        local $/;\n        <$fh>;\n    };\n\n    my $dec = gzip_decompress($enc);\n\n    gunzip(\\$enc, \\my $dec2) or die \"decompression error\";\n\n    if ($dec ne $dec2) {\n        die \"Failed to decompress correctly\";\n    }\n\n    print $out_fh $dec;\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/mygzipf_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Edit: 22 August 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Gzip from Compression::Util.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std            qw(getopts);\nuse File::Basename         qw(basename);\nuse Compression::Util      qw(:all);\nuse IO::Uncompress::Gunzip qw(gunzip);\n\nuse constant {\n              PKGNAME => 'GZIP',\n              VERSION => '0.01',\n              FORMAT  => 'gz',\n             };\n\nsub usage($code = 0) {\n\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Compress data\n    print $out_fh gzip_compress($fh, \\&lzss_encode_fast);\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    my $enc = do {\n        local $/;\n        <$fh>;\n    };\n\n    my $dec = gzip_decompress($enc);\n\n    gunzip(\\$enc, \\my $dec2) or die \"decompression error\";\n\n    if ($dec ne $dec2) {\n        die \"Failed to decompress correctly\";\n    }\n\n    print $out_fh $dec;\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/mylz4_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Edit: 25 August 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ4 from Compression::Util.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std        qw(getopts);\nuse File::Basename     qw(basename);\nuse Compression::Util  qw(:all);\nuse Compress::LZ4Frame qw();\n\nuse constant {\n              PKGNAME => 'LZ4',\n              VERSION => '0.01',\n              FORMAT  => 'lz4',\n             };\n\nsub usage ($code = 0) {\n\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Compress data\n    print $out_fh lz4_compress($fh);\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    my $enc = do {\n        local $/;\n        <$fh>;\n    };\n\n    my $dec  = lz4_decompress($enc);\n    my $dec2 = Compress::LZ4Frame::decompress($enc);\n\n    if ($dec ne $dec2) {\n        die \"Decompression error\";\n    }\n\n    print $out_fh $dec;\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/mylz4f_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Edit: 25 August 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ4 from Compression::Util (with fast LZ-parsing).\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std        qw(getopts);\nuse File::Basename     qw(basename);\nuse Compression::Util  qw(:all);\nuse Compress::LZ4Frame qw();\n\nuse constant {\n              PKGNAME => 'LZ4',\n              VERSION => '0.01',\n              FORMAT  => 'lz4',\n             };\n\nsub usage ($code = 0) {\n\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Compress data\n    print $out_fh lz4_compress($fh, \\&lzss_encode_fast);\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    my $enc = do {\n        local $/;\n        <$fh>;\n    };\n\n    my $dec  = lz4_decompress($enc);\n    my $dec2 = Compress::LZ4Frame::decompress($enc);\n\n    if ($dec ne $dec2) {\n        die \"Decompression error\";\n    }\n\n    print $out_fh $dec;\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/myzlib_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Edit: 06 November 2024\n# https://github.com/trizen\n\n# Compress/decompress files using ZLIB from Compression::Util.\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\nuse Compress::Zlib    qw();\n\nuse constant {\n              PKGNAME => 'ZLIB',\n              VERSION => '0.01',\n              FORMAT  => 'zlib',\n             };\n\nsub usage($code = 0) {\n\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Compress data\n    print $out_fh zlib_compress($fh);\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    my $enc = do {\n        local $/;\n        <$fh>;\n    };\n\n    my $dec  = zlib_decompress($enc);\n    my $dec2 = Compress::Zlib::uncompress($enc);\n\n    if ($dec ne $dec2) {\n        die \"Failed to decompress correctly\";\n    }\n\n    print $out_fh $dec;\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/rablz_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 June 2023\n# Edit: 31 July 2024\n# https://github.com/trizen\n\n# Compress/decompress files using RLE4 + Adaptive Binary Coding, followed by LZ77 compression (LZ4-like) on bits + Bzip2 on the literals.\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'RABLZ',\n    VERSION => '0.01',\n    FORMAT  => 'rablz',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        my $bits = unpack('B*', abc_encode(rle4_encode(string2symbols($chunk))));\n        my ($uncompressed, $distances, $lengths, $matches) = do {\n            local $Compression::Util::LZ_MIN_LEN       = 8 * 4;      # minimum match length\n            local $Compression::Util::LZ_MAX_LEN       = 1 << 15;    # maximum match length\n            local $Compression::Util::LZ_MAX_CHAIN_LEN = 64;         # higher value = better compression\n            lz77_encode($bits);\n        };\n        my $ubits = pack('C*', @$uncompressed);\n        my $rem   = length($ubits) % 8;\n        my $str   = pack('B*', $ubits);\n        print $out_fh chr($rem);\n        print $out_fh mrl_compress_symbolic($str, \\&lzss_compress_symbolic);\n        print $out_fh create_huffman_entry($lengths);\n        print $out_fh create_huffman_entry($matches);\n        print $out_fh obh_encode($distances, \\&mrl_compress_symbolic);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        my $rem   = ord getc $fh;\n        my $str   = symbols2string(mrl_decompress_symbolic($fh, \\&lzss_decompress_symbolic));\n        my $ubits = unpack('B*', $str);\n        if ($rem != 0) {\n            $ubits = substr($ubits, 0, -(8 - $rem));\n        }\n        my $uncompressed = [unpack('C*', $ubits)];\n        my $lengths      = decode_huffman_entry($fh);\n        my $matches      = decode_huffman_entry($fh);\n        my $distances    = obh_decode($fh, \\&mrl_decompress_symbolic);\n        my $bits         = lz77_decode($uncompressed, $distances, $lengths, $matches);\n        print $out_fh symbols2string(rle4_decode(abc_decode(pack('B*', $bits))));\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/rlzss_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 June 2023\n# Edit: 25 July 2024\n# https://github.com/trizen\n\n# Compress/decompress files using RLE4 + LZ77 compression (LZSS variant) + Huffman coding.\n\n# Encoding the literals and the pointers using a DEFLATE-like approach.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n    PKGNAME => 'RLZSS',\n    VERSION => '0.01',\n    FORMAT  => 'rlzss',\n\n    CHUNK_SIZE => 1 << 18,    # higher value = better compression\n};\n\nlocal $Compression::Util::LZ_MIN_LEN       = 4;          # minimum match length\nlocal $Compression::Util::LZ_MAX_LEN       = 1 << 15;    # maximum match length\nlocal $Compression::Util::LZ_MAX_CHAIN_LEN = 64;         # higher value = better compression\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh lzss_compress(symbols2string(rle4_encode($chunk)), \\&mrl_compress_symbolic);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        print $out_fh symbols2string(rle4_decode(lzss_decompress($fh, \\&mrl_decompress_symbolic)));\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/sbwt_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 09 November 2024\n# https://github.com/trizen\n\n# Compress/decompress files using SWAP transform + LZB + Burrows-Wheeler Transform (BWT) + Move-to-Front Transform + Run-length encoding + Huffman coding.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std       qw(getopts);\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\nuse POSIX             qw(ceil);\n\nuse constant {\n    PKGNAME => 'SBWT',\n    VERSION => '0.01',\n    FORMAT  => 'sbwt',\n\n    CHUNK_SIZE => 1 << 17,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub swap_transform ($text, $extra = 1) {\n\n    my @bits;\n    my @arr = unpack('C*', $text);\n    my $k   = 0;\n\n    foreach my $i (1 .. $#arr) {\n        if ($arr[$i] < $arr[$i - 1 - $k]) {\n            push @bits, 1;\n            unshift @arr, splice(@arr, $i, 1);\n            ++$k if $extra;\n        }\n        else {\n            push @bits, 0;\n        }\n    }\n\n    return (pack('C*', @arr), \\@bits);\n}\n\nsub reverse_swap_transform ($text, $bits) {\n    my @arr = unpack('C*', $text);\n\n    for (my $i = $#arr ; $i >= 0 ; --$i) {\n        if ($bits->[$i - 1] == 1) {\n            splice(@arr, $i, 0, shift(@arr));\n        }\n    }\n\n    pack('C*', @arr);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        local $Compression::Util::LZ_MIN_LEN = 512;\n        my ($t, $bits) = swap_transform(lzb_compress($chunk, \\&lzss_encode_fast), 0);\n        my $vrle_bits = binary_vrl_encode(join('', @$bits));\n\n        if (length($vrle_bits) < scalar @$bits) {\n            say STDERR \"With VLRE: \", length($vrle_bits), \" < \", scalar(@$bits);\n            print $out_fh chr(1);\n        }\n        else {\n            say STDERR \"Without VRLE: \", length($vrle_bits), \" > \", scalar(@$bits);\n            $vrle_bits = join('', @$bits);\n            print $out_fh chr(0);\n        }\n\n        print $out_fh pack('N', length $vrle_bits);\n\n        my ($bwt, $idx) = bwt_encode($t);\n        print $out_fh pack('B*', $vrle_bits);\n\n        my ($mtf, $alphabet) = mtf_encode(string2symbols($bwt));\n        my $rle = zrle_encode($mtf);\n        print $out_fh (pack('N', $idx) . encode_alphabet($alphabet) . create_huffman_entry($rle));\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my $with_vrle = ord(getc($fh));\n        my $bits_len  = bytes2int($fh, 4);\n        my $bits      = read_bits($fh, $bits_len);\n\n        $bits = binary_vrl_decode($bits) if $with_vrle;\n\n        my $idx      = bytes2int($fh, 4);\n        my $alphabet = decode_alphabet($fh);\n\n        my $rle  = decode_huffman_entry($fh);\n        my $mtf  = zrle_decode($rle);\n        my $bwt  = mtf_decode($mtf, $alphabet);\n        my $data = bwt_decode(pack('C*', @$bwt), $idx);\n\n        print $out_fh lzb_decompress(reverse_swap_transform($data, [split(//, $bits)]));\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/xz_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Compress files using XZ/LZMA.\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\n\nuse IO::Compress::Xz     qw(xz);\nuse IO::Uncompress::UnXz qw(unxz);\n\nuse constant {\n              PKGNAME => 'XZ',\n              VERSION => '0.01',\n              FORMAT  => 'xz',\n             };\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Compress data\n    xz($fh, $out_fh) or die \"compression error\";\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    unxz($fh, $out_fh) or die \"decompression error\";\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/zlib_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Compress files using Gzip.\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse Compress::Zlib qw(compress uncompress);\nuse File::Slurper  qw(read_binary);\n\nuse constant {\n              PKGNAME => 'ZLIB',\n              VERSION => '0.01',\n              FORMAT  => 'zlib',\n             };\n\nsub usage ($code = 0) {\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Compress data\n    print $out_fh compress(read_binary($input));\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    print $out_fh uncompress(read_binary($input));\n\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/High-level/zstd_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Compress files using Zstandard.\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\n\nuse IO::Compress::Zstd     qw(zstd);\nuse IO::Uncompress::UnZstd qw(unzstd);\n\nuse constant {\n              PKGNAME => 'ZSTD',\n              VERSION => '0.01',\n              FORMAT  => 'zst',\n             };\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Compress data\n    zstd($fh, $out_fh) or die \"compression error\";\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    unzstd($fh, $out_fh) or die \"decompression error\";\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/bbwr_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 14 June 2023\n# Edit: 19 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Binary Burrows-Wheeler Transform (BWT) + Binary Variable Run-Length Encoding.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n#\n#   Data Compression (Summer 2023) - Lecture 5 - Basic Techniques\n#   https://youtube.com/watch?v=TdFWb8mL5Gk\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\n\nuse constant {\n    PKGNAME => 'BBWR',\n    VERSION => '0.02',\n    FORMAT  => 'bbwr',\n\n    CHUNK_SIZE    => 1 << 13,    # larger values == better compression\n    LOOKAHEAD_LEN => 128,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(2);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub run_length ($arr) {\n\n    @$arr || return [];\n\n    my @result     = [$arr->[0], 1];\n    my $prev_value = $arr->[0];\n\n    foreach my $i (1 .. $#{$arr}) {\n\n        my $curr_value = $arr->[$i];\n\n        if ($curr_value eq $prev_value) {\n            ++$result[-1][1];\n        }\n        else {\n            push(@result, [$curr_value, 1]);\n        }\n\n        $prev_value = $curr_value;\n    }\n\n    return \\@result;\n}\n\nsub binary_vrl_encoding ($str) {\n\n    my @bits      = split(//, $str);\n    my $bitstring = $bits[0];\n\n    foreach my $rle (@{run_length(\\@bits)}) {\n        my ($c, $v) = @$rle;\n\n        if ($v == 1) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', $v - 1);\n            $bitstring .= join('', '1' x length($t), '0', substr($t, 1));\n        }\n    }\n\n    return $bitstring;\n}\n\nsub binary_vrl_decoding ($bitstring) {\n\n    my $decoded = '';\n    my $bit     = substr($bitstring, 0, 1, '');\n\n    while ($bitstring ne '') {\n\n        $decoded .= $bit;\n\n        my $bl = 0;\n        while (substr($bitstring, 0, 1, '') eq '1') {\n            ++$bl;\n        }\n\n        if ($bl > 0) {\n            $decoded .= $bit x oct('0b1' . join('', map { substr($bitstring, 0, 1, '') } 1 .. $bl - 1));\n        }\n\n        $bit = ($bit eq '1' ? '0' : '1');\n    }\n\n    return $decoded;\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my $bits  = unpack('B*', $chunk);\n    my $vrle1 = binary_vrl_encoding($bits);\n\n    if (length($vrle1) < length($bits)) {\n        printf \"Doing early VLR, saving %s bits\\n\", length($bits) - length($vrle1);\n        print $out_fh chr(1);\n    }\n    else {\n        print $out_fh chr(0);\n        $vrle1 = $bits;\n    }\n\n    my ($bwt, $idx) = bwt_encode($vrle1);\n    my $vrle2 = binary_vrl_encoding($bwt);\n\n    say \"BWT index: $idx\";\n\n    print $out_fh pack('N',  $idx);\n    print $out_fh pack('N',  length($vrle2));\n    print $out_fh pack('B*', $vrle2);\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $compressed_byte = ord(getc($fh) // die \"error\");\n\n    my $idx      = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    my $bits_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n\n    say \"BWT index = $idx\";\n\n    my $bwt  = binary_vrl_decoding(read_bits($fh, $bits_len));\n    my $data = bwt_decode($bwt, $idx);\n\n    if ($compressed_byte == 1) {\n        $data = binary_vrl_decoding($data);\n    }\n\n    print $out_fh pack('B*', $data);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/bqof_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# A general purpose lossless compressor, based on ideas from the QOI compressor. (+BWT)\n\n# See also:\n#   https://qoiformat.org/\n\nuse 5.036;\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\nuse List::Util        qw(max);\nuse Getopt::Std       qw(getopts);\n\nbinmode(STDIN,  \":raw\");\nbinmode(STDOUT, \":raw\");\n\nuse constant {\n              PKGNAME    => 'BQOF',\n              FORMAT     => 'bqof',\n              VERSION    => '0.01',\n              CHUNK_SIZE => 1 << 17,\n             };\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub usage ($code = 0) {\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub qof_encoder ($string) {\n\n    use constant {\n                  QOI_OP_RGB  => 0b1111_1110,\n                  QOI_OP_DIFF => 0b01_000_000,\n                  QOI_OP_RUN  => 0b11_000_000,\n                  QOI_OP_LUMA => 0b10_000_000,\n                 };\n\n    my $run     = 0;\n    my $px      = 0;\n    my $prev_px = -1;\n\n    my $rle4 = rle4_encode(string2symbols($string));\n    my ($bwt, $idx) = bwt_encode(symbols2string($rle4));\n\n    my @bytes;\n    my @table = (0) x 64;\n    my @chars = unpack('C*', $bwt);\n\n    push @bytes, unpack('C*', pack('N', $idx));\n\n    while (@chars) {\n\n        $px = shift(@chars);\n\n        if ($px == $prev_px) {\n            if (++$run == 62) {\n                push @bytes, QOI_OP_RUN | ($run - 1);\n                $run = 0;\n            }\n        }\n        else {\n\n            if ($run > 0) {\n                push @bytes, (QOI_OP_RUN | ($run - 1));\n                $run = 0;\n            }\n\n            my $hash     = $px % 64;\n            my $index_px = $table[$hash];\n\n            if ($px == $index_px) {\n                push @bytes, $hash;\n            }\n            else {\n\n                $table[$hash] = $px;\n                my $diff = $px - $prev_px;\n\n                if ($diff > -33 and $diff < 32) {\n                    push(@bytes, QOI_OP_DIFF | ($diff + 32));\n                }\n                else {\n                    push(@bytes, QOI_OP_RGB, $px);\n                }\n            }\n        }\n\n        $prev_px = $px;\n    }\n\n    if ($run > 0) {\n        push(@bytes, QOI_OP_RUN | ($run - 1));\n    }\n\n    create_huffman_entry(\\@bytes);\n}\n\nsub qof_decoder ($fh) {\n\n    use constant {\n                  QOI_OP_RGB   => 0b1111_1110,\n                  QOI_OP_DIFF  => 0b01_000_000,\n                  QOI_OP_RUN   => 0b11_000_000,\n                  QOI_OP_LUMA  => 0b10_000_000,\n                  QOI_OP_INDEX => 0b00_000_000,\n                 };\n\n    my $run = 0;\n    my $px  = -1;\n\n    my @bytes;\n    my @table = ((0) x 64);\n\n    my $index   = 0;\n    my @symbols = @{decode_huffman_entry($fh)};\n\n    my $idx = unpack('N', pack('C*', map { $symbols[$index++] } 1 .. 4));\n\n    while (1) {\n\n        if ($run > 0) {\n            --$run;\n        }\n        else {\n            my $byte = $symbols[$index++] // last;\n\n            if ($byte == QOI_OP_RGB) {    # OP RGB\n                $px = $symbols[$index++];\n            }\n            elsif (($byte >> 6) == (QOI_OP_INDEX >> 6)) {    # OP INDEX\n                $px = $table[$byte];\n            }\n            elsif (($byte >> 6) == (QOI_OP_DIFF >> 6)) {     # OP DIFF\n                $px += ($byte & 0b00_111_111) - 32;\n            }\n            elsif (($byte >> 6) == (QOI_OP_RUN >> 6)) {      # OP RUN\n                $run = ($byte & 0b00_111_111);\n            }\n\n            $table[$px % 64] = $px;\n        }\n\n        push @bytes, $px;\n    }\n\n    my $bwt  = pack('C*', @bytes);\n    my $rle4 = string2symbols(bwt_decode($bwt, $idx));\n\n    return symbols2string(rle4_decode($rle4));\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh qof_encoder($chunk);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        print $out_fh qof_decoder($fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/bwac_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 14 June 2023\n# Edit: 06 February 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-Front Transform + Run-length encoding + Arithmetic Coding.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n#\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\n\nuse constant {\n    PKGNAME => 'BWAC',\n    VERSION => '0.02',\n    FORMAT  => 'bwac',\n\n    # BWT settings\n    CHUNK_SIZE    => 1 << 17,\n    LOOKAHEAD_LEN => 128,\n};\n\n# Arithmetic Coding settings\nuse constant BITS => 32;\nuse constant MAX  => oct('0b' . ('1' x BITS));\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(2);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub create_cfreq ($freq) {\n\n    my @cf;\n    my $T = 0;\n\n    foreach my $i (sort { $a <=> $b } keys %$freq) {\n        $freq->{$i} // next;\n        $cf[$i] = $T;\n        $T += $freq->{$i};\n        $cf[$i + 1] = $T;\n    }\n\n    return (\\@cf, $T);\n}\n\nsub ac_encode ($bytes_arr) {\n\n    my $enc        = '';\n    my $EOF_SYMBOL = (max(@$bytes_arr) // 0) + 1;\n    my @bytes      = (@$bytes_arr, $EOF_SYMBOL);\n\n    my %freq;\n    ++$freq{$_} for @bytes;\n\n    my ($cf, $T) = create_cfreq(\\%freq);\n\n    if ($T > MAX) {\n        die \"Too few bits: $T > ${\\MAX}\";\n    }\n\n    my $low      = 0;\n    my $high     = MAX;\n    my $uf_count = 0;\n\n    foreach my $c (@bytes) {\n\n        my $w = $high - $low + 1;\n\n        $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$c]) / $T)) & MAX;\n\n        if ($high > MAX) {\n            die \"high > MAX: $high > ${\\MAX}\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n\n                my $bit = $high >> (BITS - 1);\n                $enc .= $bit;\n\n                if ($uf_count > 0) {\n                    $enc .= join('', 1 - $bit) x $uf_count;\n                    $uf_count = 0;\n                }\n\n                $low <<= 1;\n                ($high <<= 1) |= 1;\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                ++$uf_count;\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n        }\n    }\n\n    $enc .= '0';\n    $enc .= '1';\n\n    while (length($enc) % 8 != 0) {\n        $enc .= '1';\n    }\n\n    return ($enc, \\%freq);\n}\n\nsub ac_decode ($fh, $freq) {\n\n    my ($cf, $T) = create_cfreq($freq);\n\n    my @dec;\n    my $low  = 0;\n    my $high = MAX;\n    my $enc  = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS);\n\n    my @table;\n    foreach my $i (sort { $a <=> $b } keys %$freq) {\n        foreach my $j ($cf->[$i] .. $cf->[$i + 1] - 1) {\n            $table[$j] = $i;\n        }\n    }\n\n    my $EOF_SYMBOL = max(keys %$freq) // 0;\n\n    while (1) {\n\n        my $w  = $high - $low + 1;\n        my $ss = int((($T * ($enc - $low + 1)) - 1) / $w);\n\n        my $i = $table[$ss] // last;\n        last if ($i == $EOF_SYMBOL);\n\n        push @dec, $i;\n\n        $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$i]) / $T)) & MAX;\n\n        if ($high > MAX) {\n            die \"error\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n                ($high <<= 1) |= 1;\n                $low <<= 1;\n                ($enc <<= 1) |= (getc($fh) // 1);\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1);\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n            $enc  &= MAX;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub create_ac_entry ($bytes, $out_fh) {\n\n    my ($enc, $freq) = ac_encode($bytes);\n    my $max_symbol = max(keys %$freq) // 0;\n\n    my @freqs;\n    foreach my $k (0 .. $max_symbol) {\n        push @freqs, $freq->{$k} // 0;\n    }\n\n    push @freqs, length($enc) >> 3;\n\n    say \"Max symbol: $max_symbol\\n\";\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_ac_entry ($fh) {\n\n    my @freqs    = @{delta_decode($fh)};\n    my $bits_len = pop(@freqs);\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    say \"Encoded length: $bits_len\\n\";\n    my $bits = read_bits($fh, $bits_len << 3);\n\n    if ($bits_len > 0) {\n        open my $bits_fh, '<:raw', \\$bits;\n        return ac_decode($bits_fh, \\%freq);\n    }\n\n    return [];\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        if ($enc == 0) {\n            $populated <<= 1;\n        }\n        else {\n            ($populated <<= 1) |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta);\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh))));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my $rle1 = rle4_encode([unpack('C*', $chunk)]);\n    my ($bwt, $idx) = bwt_encode(pack('C*', @$rle1));\n\n    say \"BWT index = $idx\";\n\n    my @bytes        = unpack('C*', $bwt);\n    my @alphabet     = sort { $a <=> $b } uniq(@bytes);\n    my $alphabet_enc = encode_alphabet(\\@alphabet);\n\n    my $mtf = mtf_encode(\\@bytes, [@alphabet]);\n    my $rle = rle_encode($mtf);\n\n    print $out_fh pack('N', $idx);\n    print $out_fh $alphabet_enc;\n    create_ac_entry($rle, $out_fh);\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $idx      = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4));\n    my $alphabet = decode_alphabet($fh);\n\n    say \"BWT index = $idx\";\n    say \"Alphabet size: \", scalar(@$alphabet);\n\n    my $rle  = decode_ac_entry($fh);\n    my $mtf  = rle_decode($rle);\n    my $bwt  = mtf_decode($mtf, $alphabet);\n    my $rle4 = bwt_decode(pack('C*', @$bwt), $idx);\n    my $data = rle4_decode([unpack('C*', $rle4)]);\n\n    print $out_fh pack('C*', @$data);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/bwad_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 14 June 2023\n# Edit: 06 February 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-Front Transform + Run-length encoding + Adaptive Arithmetic Coding (in fixed bits).\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n#\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\n\nuse constant {\n    PKGNAME => 'BWAD',\n    VERSION => '0.02',\n    FORMAT  => 'bwad',\n\n    CHUNK_SIZE    => 1 << 17,\n    LOOKAHEAD_LEN => 128,\n};\n\n# Arithmetic Coding settings\nuse constant BITS         => 32;\nuse constant MAX          => oct('0b' . ('1' x BITS));\nuse constant INITIAL_FREQ => 1;\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(2);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub _create_adaptive_cfreq ($freq_value, $max_symbol) {\n\n    my $T = 0;\n    my (@cf, @freq);\n\n    foreach my $i (0 .. $max_symbol) {\n        $freq[$i] = $freq_value;\n        $cf[$i]   = $T;\n        $T += $freq_value;\n        $cf[$i + 1] = $T;\n    }\n\n    return (\\@freq, \\@cf, $T);\n}\n\nsub increment_freq ($c, $max_symbol, $freq, $cf) {\n\n    ++$freq->[$c];\n    my $T = $cf->[$c];\n\n    foreach my $i ($c .. $max_symbol) {\n        $cf->[$i] = $T;\n        $T += $freq->[$i];\n        $cf->[$i + 1] = $T;\n    }\n\n    return $T;\n}\n\nsub adaptive_ac_encode ($bytes_arr) {\n\n    my $enc   = '';\n    my @bytes = (@$bytes_arr, (max(@$bytes_arr) // 0) + 1);\n\n    my $max_symbol = max(@bytes) // 0;\n    my ($freq, $cf, $T) = _create_adaptive_cfreq(INITIAL_FREQ, $max_symbol);\n\n    if ($T > MAX) {\n        die \"Too few bits: $T > ${\\MAX}\";\n    }\n\n    my $low      = 0;\n    my $high     = MAX;\n    my $uf_count = 0;\n\n    foreach my $c (@bytes) {\n\n        my $w = $high - $low + 1;\n\n        $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$c]) / $T)) & MAX;\n\n        $T = increment_freq($c, $max_symbol, $freq, $cf);\n\n        if ($high > MAX) {\n            die \"high > MAX: $high > ${\\MAX}\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n\n                my $bit = $high >> (BITS - 1);\n                $enc .= $bit;\n\n                if ($uf_count > 0) {\n                    $enc .= join('', 1 - $bit) x $uf_count;\n                    $uf_count = 0;\n                }\n\n                $low <<= 1;\n                ($high <<= 1) |= 1;\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                ++$uf_count;\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n        }\n    }\n\n    $enc .= '0';\n    $enc .= '1';\n\n    while (length($enc) % 8 != 0) {\n        $enc .= '1';\n    }\n\n    return ($enc, $max_symbol);\n}\n\nsub adaptive_ac_decode ($fh, $max_symbol) {\n\n    my ($freq, $cf, $T) = _create_adaptive_cfreq(INITIAL_FREQ, $max_symbol);\n\n    my @dec;\n    my $low  = 0;\n    my $high = MAX;\n\n    my $enc = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS);\n\n    while (1) {\n        my $w  = ($high + 1) - $low;\n        my $ss = int((($T * ($enc - $low + 1)) - 1) / $w);\n\n        my $i = 0;\n        foreach my $j (0 .. $max_symbol) {\n            if ($cf->[$j] <= $ss and $ss < $cf->[$j + 1]) {\n                $i = $j;\n                last;\n            }\n        }\n\n        last if ($i == $max_symbol);\n        push @dec, $i;\n\n        $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$i]) / $T)) & MAX;\n\n        $T = increment_freq($i, $max_symbol, $freq, $cf);\n\n        if ($high > MAX) {\n            die \"high > MAX: ($high > ${\\MAX})\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n                ($high <<= 1) |= 1;\n                $low <<= 1;\n                ($enc <<= 1) |= (getc($fh) // 1);\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1);\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n            $enc  &= MAX;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub create_adaptive_ac_entry ($bytes, $out_fh) {\n\n    my ($enc, $max_symbol) = adaptive_ac_encode($bytes);\n\n    say \"Max symbol: $max_symbol\\n\";\n\n    print $out_fh delta_encode([$max_symbol, length($enc)], 1);\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_adaptive_ac_entry ($fh) {\n\n    my ($max_symbol, $enc_len) = @{delta_decode($fh, 1)};\n\n    say \"Encoded length: $enc_len\\n\";\n\n    if ($enc_len > 0) {\n        my $bits = read_bits($fh, $enc_len);\n        open my $bits_fh, '<:raw', \\$bits;\n        return adaptive_ac_decode($bits_fh, $max_symbol);\n    }\n\n    return [];\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        if ($enc == 0) {\n            $populated <<= 1;\n        }\n        else {\n            ($populated <<= 1) |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta);\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh))));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my $rle1 = rle4_encode([unpack('C*', $chunk)]);\n    my ($bwt, $idx) = bwt_encode(pack('C*', @$rle1));\n\n    say \"BWT index = $idx\";\n\n    my @bytes        = unpack('C*', $bwt);\n    my @alphabet     = sort { $a <=> $b } uniq(@bytes);\n    my $alphabet_enc = encode_alphabet(\\@alphabet);\n\n    my $mtf = mtf_encode(\\@bytes, [@alphabet]);\n    my $rle = rle_encode($mtf);\n\n    print $out_fh pack('N', $idx);\n    print $out_fh $alphabet_enc;\n    create_adaptive_ac_entry($rle, $out_fh);\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $idx      = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4));\n    my $alphabet = decode_alphabet($fh);\n\n    say \"BWT index = $idx\";\n    say \"Alphabet size: \", scalar(@$alphabet);\n\n    my $rle  = decode_adaptive_ac_entry($fh);\n    my $mtf  = rle_decode($rle);\n    my $bwt  = mtf_decode($mtf, $alphabet);\n    my $rle4 = bwt_decode(pack('C*', @$bwt), $idx);\n    my $data = rle4_decode([unpack('C*', $rle4)]);\n\n    print $out_fh pack('C*', @$data);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/bwaz_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 14 June 2023\n# Edit: 14 July 2023\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-Front Transform + Run-length encoding + Arithmetic Coding (big-integer version).\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(sum max uniq);\nuse Math::GMPz;\n\nuse constant {\n    PKGNAME => 'BWAZ',\n    VERSION => '0.01',\n    FORMAT  => 'bwaz',\n\n    CHUNK_SIZE    => 1 << 16,\n    LOOKAHEAD_LEN => 128,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub cumulative_freq ($freq) {\n\n    my %cf;\n    my $total = 0;\n    foreach my $c (sort { $a <=> $b } keys %$freq) {\n        $cf{$c} = $total;\n        $total += $freq->{$c};\n    }\n\n    return %cf;\n}\n\nsub ac_encode ($bytes_arr) {\n\n    my @chars = @$bytes_arr;\n\n    # The frequency characters\n    my %freq;\n    ++$freq{$_} for @chars;\n\n    # Create the cumulative frequency table\n    my %cf = cumulative_freq(\\%freq);\n\n    # Limit and base\n    my $base = Math::GMPz->new(scalar @chars);\n\n    # Lower bound\n    my $L = Math::GMPz->new(0);\n\n    # Product of all frequencies\n    my $pf = Math::GMPz->new(1);\n\n    # Each term is multiplied by the product of the\n    # frequencies of all previously occurring symbols\n    foreach my $c (@chars) {\n        Math::GMPz::Rmpz_mul($L, $L, $base);\n        Math::GMPz::Rmpz_addmul_ui($L, $pf, $cf{$c});\n        Math::GMPz::Rmpz_mul_ui($pf, $pf, $freq{$c});\n    }\n\n    # Upper bound\n    Math::GMPz::Rmpz_add($L, $L, $pf);\n\n    # Compute the power for left shift\n    my $pow = Math::GMPz::Rmpz_sizeinbase($pf, 2) - 1;\n\n    # Set $enc to (U-1) divided by 2^pow\n    Math::GMPz::Rmpz_sub_ui($L, $L, 1);\n    Math::GMPz::Rmpz_div_2exp($L, $L, $pow);\n\n    # Remove any divisibility by 2\n    if ($L > 0 and Math::GMPz::Rmpz_even_p($L)) {\n        $pow += Math::GMPz::Rmpz_remove($L, $L, Math::GMPz->new(2));\n    }\n\n    my $bin = Math::GMPz::Rmpz_get_str($L, 2);\n\n    return ($bin, $pow, \\%freq);\n}\n\nsub ac_decode ($bits, $pow2, $freq) {\n\n    # Decode the bits into an integer\n    my $enc = Math::GMPz->new($bits, 2);\n    Math::GMPz::Rmpz_mul_2exp($enc, $enc, $pow2);\n\n    my $base = sum(values %$freq) // 0;\n\n    if ($base == 0) {\n        return [];\n    }\n    elsif ($base == 1) {\n        return [keys %$freq];\n    }\n\n    # Create the cumulative frequency table\n    my %cf = cumulative_freq($freq);\n\n    # Create the dictionary\n    my %dict;\n    while (my ($k, $v) = each %cf) {\n        $dict{$v} = $k;\n    }\n\n    # Fill the gaps in the dictionary\n    my $lchar;\n    foreach my $i (0 .. $base - 1) {\n        if (exists $dict{$i}) {\n            $lchar = $dict{$i};\n        }\n        elsif (defined $lchar) {\n            $dict{$i} = $lchar;\n        }\n    }\n\n    my $div = Math::GMPz::Rmpz_init();\n\n    my @dec;\n\n    # Decode the input number\n    for (my $pow = Math::GMPz->new($base)**($base - 1) ; Math::GMPz::Rmpz_sgn($pow) > 0 ; Math::GMPz::Rmpz_tdiv_q_ui($pow, $pow, $base)) {\n\n        Math::GMPz::Rmpz_tdiv_q($div, $enc, $pow);\n\n        my $c  = $dict{$div};\n        my $fv = $freq->{$c};\n        my $cv = $cf{$c};\n\n        Math::GMPz::Rmpz_submul_ui($enc, $pow, $cv);\n        Math::GMPz::Rmpz_tdiv_q_ui($enc, $enc, $fv);\n\n        push @dec, $c;\n    }\n\n    return \\@dec;\n}\n\nsub create_ac_entry ($bytes, $out_fh) {\n\n    my ($enc, $pow, $freq) = ac_encode($bytes);\n\n    my @freqs;\n    my $max_symbol = max(keys %$freq) // 0;\n\n    foreach my $k (0 .. $max_symbol) {\n        push @freqs, $freq->{$k} // 0;\n    }\n\n    push @freqs, $pow;\n    push @freqs, length($enc);\n\n    say \"Max symbol: $max_symbol\\n\";\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_ac_entry ($fh) {\n\n    my @freqs    = @{delta_decode($fh)};\n    my $bits_len = pop(@freqs);\n    my $pow2     = pop(@freqs);\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    say \"Encoded length: $bits_len\\n\";\n    my $bits = read_bits($fh, $bits_len);\n\n    if ($bits_len > 0) {\n        return ac_decode($bits, $pow2, \\%freq);\n    }\n\n    return [];\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        if ($enc == 0) {\n            $populated <<= 1;\n        }\n        else {\n            ($populated <<= 1) |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta);\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh))));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my $rle1 = rle4_encode([unpack('C*', $chunk)]);\n    my ($bwt, $idx) = bwt_encode(pack('C*', @$rle1));\n\n    say \"BWT index = $idx\";\n\n    my @bytes        = unpack('C*', $bwt);\n    my @alphabet     = sort { $a <=> $b } uniq(@bytes);\n    my $alphabet_enc = encode_alphabet(\\@alphabet);\n\n    my $mtf = mtf_encode(\\@bytes, [@alphabet]);\n    my $rle = rle_encode($mtf);\n\n    print $out_fh pack('N', $idx);\n    print $out_fh $alphabet_enc;\n    create_ac_entry($rle, $out_fh);\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $idx      = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4));\n    my $alphabet = decode_alphabet($fh);\n\n    say \"BWT index = $idx\";\n    say \"Alphabet size: \", scalar(@$alphabet);\n\n    my $rle  = decode_ac_entry($fh);\n    my $mtf  = rle_decode($rle);\n    my $bwt  = mtf_decode($mtf, $alphabet);\n    my $rle4 = bwt_decode(pack('C*', @$bwt), $idx);\n    my $data = rle4_decode([unpack('C*', $rle4)]);\n\n    print $out_fh pack('C*', @$data);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/bwlz2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 June 2023\n# Edit: 19 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + LZ77 compression + Symbolic Bzip2.\n\n# Encoding the literals and the pointers using a DEFLATE-like approach.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n#\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\nuse POSIX          qw(ceil log2);\n\nuse constant {\n    PKGNAME => 'BWLZ2',\n    VERSION => '0.01',\n    FORMAT  => 'bwlz2',\n\n    CHUNK_SIZE    => 1 << 17,    # higher value = better compression\n    LOOKAHEAD_LEN => 128,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\n# [distance value, offset bits]\nmy @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4);\n\nuntil ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) {\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n}\n\n# [length, offset bits]\nmy @LENGTH_SYMBOLS = ((map { [$_, 0] } (3 .. 10)));\n\n{\n    my $delta = 1;\n    until ($LENGTH_SYMBOLS[-1][0] > 163) {\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1];\n        $delta *= 2;\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n    }\n    push @LENGTH_SYMBOLS, [258, 0];\n}\n\nmy @DISTANCE_INDICES;\n\nforeach my $i (0 .. $#DISTANCE_SYMBOLS) {\n    my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        last if ($k > CHUNK_SIZE);\n        $DISTANCE_INDICES[$k] = $i;\n    }\n}\n\nmy @LENGTH_INDICES;\n\nforeach my $i (0 .. $#LENGTH_SYMBOLS) {\n    my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        $LENGTH_INDICES[$k] = $i;\n    }\n}\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    my $min_len = $LENGTH_SYMBOLS[0][0];\n    my $max_len = $LENGTH_SYMBOLS[-1][0];\n\n    my %literal_freq;\n    my %distance_freq;\n\n    my $literal_count  = 0;\n    my $distance_count = 0;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n <= $max_len\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        my $enc_bits_len     = 0;\n        my $literal_bits_len = 0;\n\n        if ($n > $min_len) {\n\n            my $dist = $DISTANCE_SYMBOLS[$DISTANCE_INDICES[$la - $p]];\n            $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0))));\n\n            my $len_idx = $LENGTH_INDICES[$n - 1];\n            my $len     = $LENGTH_SYMBOLS[$len_idx];\n\n            $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0))));\n\n            my %freq;\n            foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) {\n                ++$freq{$c};\n                $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0))));\n            }\n        }\n\n        if ($n > $min_len and $enc_bits_len < $literal_bits_len) {\n\n            push @$lengths,      $n - 1;\n            push @$indices,      $la - $p;\n            push @$uncompressed, undef;\n\n            my $dist_idx = $DISTANCE_INDICES[$la - $p];\n            my $dist     = $DISTANCE_SYMBOLS[$dist_idx];\n\n            ++$distance_count;\n            ++$distance_freq{$dist->[0]};\n\n            ++$literal_count;\n            ++$literal_freq{$LENGTH_INDICES[$n - 1] + 256};\n\n            $la += $n - 1;\n            $prefix .= substr($token, 0, -1);\n        }\n        else {\n            my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]);\n\n            push @$uncompressed, @bytes;\n            push @$lengths, (0) x scalar(@bytes);\n            push @$indices, (0) x scalar(@bytes);\n\n            ++$literal_freq{$_} for @bytes;\n\n            $literal_count += $n;\n            $la            += $n;\n            $prefix .= $token;\n        }\n    }\n\n    return;\n}\n\nsub lz77_decompression ($literals, $distances, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#$literals) {\n        if ($lengths->[$i] != 0) {\n            $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]);\n            $offset += $lengths->[$i];\n        }\n        else {\n            $chunk .= chr($literals->[$i]);\n            $offset += 1;\n        }\n    }\n\n    return $chunk;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n    say \"Max symbol: $max_symbol\";\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\nsub encode_alphabet_symbolic ($alphabet) {\n    return delta_encode([@$alphabet]);\n}\n\nsub decode_alphabet_symbolic ($fh) {\n    return delta_decode($fh);\n}\n\nsub bz2_compression_symbolic ($symbols, $out_fh) {\n\n    my ($bwt, $idx) = bwt_encode_symbolic($symbols);\n\n    say \"BWT index = $idx\";\n\n    my @bytes        = @$bwt;\n    my @alphabet     = sort { $a <=> $b } uniq(@bytes);\n    my $alphabet_enc = encode_alphabet_symbolic(\\@alphabet);\n\n    my $mtf = mtf_encode(\\@bytes, [@alphabet]);\n    my $rle = rle_encode($mtf);\n\n    print $out_fh pack('N', $idx);\n    print $out_fh $alphabet_enc;\n    create_huffman_entry($rle, $out_fh);\n}\n\nsub bz2_decompression_symbolic ($fh) {\n\n    my $idx      = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    my $alphabet = decode_alphabet_symbolic($fh);\n\n    say \"BWT index = $idx\";\n    say \"Alphabet size: \", scalar(@$alphabet);\n\n    my $rle  = decode_huffman_entry($fh);\n    my $mtf  = rle_decode($rle);\n    my $bwt  = mtf_decode($mtf, $alphabet);\n    my $data = bwt_decode_symbolic($bwt, $idx);\n\n    return $data;\n}\n\nsub deflate_encode ($literals, $distances, $lengths, $out_fh) {\n\n    my @len_symbols;\n    my @dist_symbols;\n    my $offset_bits = '';\n\n    foreach my $j (0 .. $#{$literals}) {\n\n        if ($lengths->[$j] == 0) {\n            push @len_symbols, $literals->[$j];\n            next;\n        }\n\n        my $len  = $lengths->[$j];\n        my $dist = $distances->[$j];\n\n        {\n            my $len_idx = $LENGTH_INDICES[$len];\n            my ($min, $bits) = @{$LENGTH_SYMBOLS[$len_idx]};\n\n            push @len_symbols, $len_idx + 256;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $len - $min);\n            }\n        }\n\n        {\n            my $dist_idx = $DISTANCE_INDICES[$dist];\n            my ($min, $bits) = @{$DISTANCE_SYMBOLS[$dist_idx]};\n\n            push @dist_symbols, $dist_idx;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $dist - $min);\n            }\n        }\n    }\n\n    bz2_compression_symbolic(\\@len_symbols,  $out_fh);\n    bz2_compression_symbolic(\\@dist_symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n}\n\nsub deflate_decode ($fh) {\n\n    my $len_symbols  = bz2_decompression_symbolic($fh);\n    my $dist_symbols = bz2_decompression_symbolic($fh);\n\n    my $bits_len = 0;\n\n    foreach my $i (@$dist_symbols) {\n        $bits_len += $DISTANCE_SYMBOLS[$i][1];\n    }\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            $bits_len += $LENGTH_SYMBOLS[$i - 256][1];\n        }\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @literals;\n    my @lengths;\n    my @distances;\n\n    my $j = 0;\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            my $dist = $dist_symbols->[$j++];\n            push @literals,  undef;\n            push @lengths,   $LENGTH_SYMBOLS[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS[$i - 256][1], ''));\n            push @distances, $DISTANCE_SYMBOLS[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$dist][1], ''));\n        }\n        else {\n            push @literals,  $i;\n            push @lengths,   0;\n            push @distances, 0;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub bwt_sort_symbolic ($s) {    # O(n) space (slowish)\n\n    my @cyclic = @$s;\n    my $len    = scalar(@cyclic);\n\n    my $rle = 1;\n    foreach my $i (1 .. $len - 1) {\n        if ($cyclic[$i] != $cyclic[$i - 1]) {\n            $rle = 0;\n            last;\n        }\n    }\n\n    $rle && return [0 .. $len - 1];\n\n    [\n     sort {\n         my ($i, $j) = ($a, $b);\n\n         while ($cyclic[$i] == $cyclic[$j]) {\n             $i %= $len if (++$i >= $len);\n             $j %= $len if (++$j >= $len);\n         }\n\n         $cyclic[$i] <=> $cyclic[$j];\n       } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode_symbolic ($s) {\n\n    my $bwt = bwt_sort_symbolic($s);\n    my @ret = map { $s->[$_ - 1] } @$bwt;\n\n    my $idx = 0;\n    foreach my $i (@$bwt) {\n        $i || last;\n        ++$idx;\n    }\n\n    return (\\@ret, $idx);\n}\n\nsub bwt_decode_symbolic ($bwt, $idx) {    # fast inversion\n\n    my @tail = @$bwt;\n    my @head = sort { $a <=> $b } @tail;\n\n    my @indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices[$tail[$i]]}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices[$v]});\n    }\n\n    my @dec;\n    my $i = $idx;\n\n    for (1 .. scalar(@head)) {\n        push @dec, $head[$i];\n        $i = $table[$i];\n    }\n\n    return \\@dec;\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 254 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        if ($enc == 0) {\n            $populated <<= 1;\n        }\n        else {\n            ($populated <<= 1) |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta);\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh) // die \"error\")));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\nsub lzss_compression ($chunk, $out_fh) {\n\n    my (@uncompressed, @indices, @lengths);\n    lz77_compression($chunk, \\@uncompressed, \\@indices, \\@lengths);\n\n    my $est_ratio = length($chunk) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices));\n    say \"\\nEst. ratio: \", $est_ratio, \" (\", scalar(@uncompressed), \" uncompressed bytes)\";\n\n    deflate_encode(\\@uncompressed, \\@indices, \\@lengths, $out_fh);\n}\n\nsub lzss_decompression ($fh) {\n    my ($uncompressed, $indices, $lengths) = deflate_decode($fh);\n    lz77_decompression($uncompressed, $indices, $lengths);\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my @chunk_bytes = unpack('C*', $chunk);\n    my $data        = pack('C*', @{rle4_encode(\\@chunk_bytes)});\n\n    my ($bwt, $idx) = bwt_encode($data);\n\n    my @bytes    = unpack('C*', $bwt);\n    my @alphabet = sort { $a <=> $b } uniq(@bytes);\n\n    my $enc_bytes = mtf_encode(\\@bytes, [@alphabet]);\n\n    if (max(@$enc_bytes) < 255) {\n        print $out_fh chr(1);\n        $enc_bytes = rle_encode($enc_bytes);\n    }\n    else {\n        print $out_fh chr(0);\n        $enc_bytes = rle4_encode($enc_bytes);\n    }\n\n    print $out_fh pack('N', $idx);\n    print $out_fh encode_alphabet(\\@alphabet);\n    lzss_compression(pack('C*', @$enc_bytes), $out_fh);\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $rle_encoded = ord(getc($fh) // die \"error\");\n    my $idx         = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    my $alphabet    = decode_alphabet($fh);\n\n    my $bytes = [unpack('C*', lzss_decompression($fh))];\n\n    if ($rle_encoded) {\n        $bytes = rle_decode($bytes);\n    }\n    else {\n        $bytes = rle4_decode($bytes);\n    }\n\n    $bytes = mtf_decode($bytes, [@$alphabet]);\n\n    print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode(pack('C*', @$bytes), $idx))])});\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/bwlz_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 June 2023\n# Edit: 20 June 2023\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-front transform (MTF) + LZ77 compression (LZSS) + Huffman coding.\n\n# Encoding the literals and the pointers using a DEFLATE-like approach.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n#\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\nuse POSIX          qw(ceil log2);\n\nuse constant {\n    PKGNAME => 'BWLZ',\n    VERSION => '0.05',\n    FORMAT  => 'bwlz',\n\n    CHUNK_SIZE    => 1 << 17,    # higher value = better compression\n    LOOKAHEAD_LEN => 128,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(5);\n\n# [distance value, offset bits]\nmy @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4);\n\nuntil ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) {\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n}\n\n# [length, offset bits]\nmy @LENGTH_SYMBOLS = ((map { [$_, 0] } (4 .. 10)));\n\n{\n    my $delta = 1;\n    until ($LENGTH_SYMBOLS[-1][0] > 163) {\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1];\n        $delta *= 2;\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n    }\n    push @LENGTH_SYMBOLS, [258, 0];\n}\n\nmy @DISTANCE_INDICES;\n\nforeach my $i (0 .. $#DISTANCE_SYMBOLS) {\n    my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        last if ($k > CHUNK_SIZE);\n        $DISTANCE_INDICES[$k] = $i;\n    }\n}\n\nmy @LENGTH_INDICES;\n\nforeach my $i (0 .. $#LENGTH_SYMBOLS) {\n    my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        $LENGTH_INDICES[$k] = $i;\n    }\n}\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    my $min_len = $LENGTH_SYMBOLS[0][0];\n    my $max_len = $LENGTH_SYMBOLS[-1][0];\n\n    my %literal_freq;\n    my %distance_freq;\n\n    my $literal_count  = 0;\n    my $distance_count = 0;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n <= $max_len\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        my $enc_bits_len     = 0;\n        my $literal_bits_len = 0;\n\n        if ($n > $min_len) {\n\n            my $dist = $DISTANCE_SYMBOLS[$DISTANCE_INDICES[$la - $p]];\n            $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0))));\n\n            my $len_idx = $LENGTH_INDICES[$n - 1];\n            my $len     = $LENGTH_SYMBOLS[$len_idx];\n\n            $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0))));\n\n            my %freq;\n            foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) {\n                ++$freq{$c};\n                $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0))));\n            }\n        }\n\n        if ($n > $min_len and $enc_bits_len < $literal_bits_len) {\n\n            push @$lengths,      $n - 1;\n            push @$indices,      $la - $p;\n            push @$uncompressed, undef;\n\n            my $dist_idx = $DISTANCE_INDICES[$la - $p];\n            my $dist     = $DISTANCE_SYMBOLS[$dist_idx];\n\n            ++$distance_count;\n            ++$distance_freq{$dist->[0]};\n\n            ++$literal_count;\n            ++$literal_freq{$LENGTH_INDICES[$n - 1] + 256};\n\n            $la += $n - 1;\n            $prefix .= substr($token, 0, -1);\n        }\n        else {\n            my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]);\n\n            push @$uncompressed, @bytes;\n            push @$lengths, (0) x scalar(@bytes);\n            push @$indices, (0) x scalar(@bytes);\n\n            ++$literal_freq{$_} for @bytes;\n\n            $literal_count += $n;\n            $la            += $n;\n            $prefix .= $token;\n        }\n    }\n\n    return;\n}\n\nsub lz77_decompression ($literals, $distances, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#$literals) {\n        if ($lengths->[$i] != 0) {\n            $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]);\n            $offset += $lengths->[$i];\n        }\n        else {\n            $chunk .= chr($literals->[$i]);\n            $offset += 1;\n        }\n    }\n\n    return $chunk;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n    say \"Max symbol: $max_symbol\";\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\nsub deflate_encode ($literals, $distances, $lengths, $out_fh) {\n\n    my @len_symbols;\n    my @dist_symbols;\n    my $offset_bits = '';\n\n    foreach my $j (0 .. $#{$literals}) {\n\n        if ($lengths->[$j] == 0) {\n            push @len_symbols, $literals->[$j];\n            next;\n        }\n\n        my $len  = $lengths->[$j];\n        my $dist = $distances->[$j];\n\n        {\n            my $len_idx = $LENGTH_INDICES[$len];\n            my ($min, $bits) = @{$LENGTH_SYMBOLS[$len_idx]};\n\n            push @len_symbols, $len_idx + 256;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $len - $min);\n            }\n        }\n\n        {\n            my $dist_idx = $DISTANCE_INDICES[$dist];\n            my ($min, $bits) = @{$DISTANCE_SYMBOLS[$dist_idx]};\n\n            push @dist_symbols, $dist_idx;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $dist - $min);\n            }\n        }\n    }\n\n    create_huffman_entry(\\@len_symbols,  $out_fh);\n    create_huffman_entry(\\@dist_symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n}\n\nsub deflate_decode ($fh) {\n\n    my $len_symbols  = decode_huffman_entry($fh);\n    my $dist_symbols = decode_huffman_entry($fh);\n\n    my $bits_len = 0;\n\n    foreach my $i (@$dist_symbols) {\n        $bits_len += $DISTANCE_SYMBOLS[$i][1];\n    }\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            $bits_len += $LENGTH_SYMBOLS[$i - 256][1];\n        }\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @literals;\n    my @lengths;\n    my @distances;\n\n    my $j = 0;\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            my $dist = $dist_symbols->[$j++];\n            push @literals,  undef;\n            push @lengths,   $LENGTH_SYMBOLS[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS[$i - 256][1], ''));\n            push @distances, $DISTANCE_SYMBOLS[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$dist][1], ''));\n        }\n        else {\n            push @literals,  $i;\n            push @lengths,   0;\n            push @distances, 0;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 254 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        if ($enc == 0) {\n            $populated <<= 1;\n        }\n        else {\n            ($populated <<= 1) |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta);\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh) // die \"error\")));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\nsub lzss_compression ($data, $out_fh) {\n    my (@uncompressed, @indices, @lengths);\n    lz77_compression($data, \\@uncompressed, \\@indices, \\@lengths);\n\n    my $est_ratio = length($data) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices));\n    say \"\\nEst. ratio: \", $est_ratio, \" (\", scalar(@uncompressed), \" uncompressed bytes)\";\n\n    deflate_encode(\\@uncompressed, \\@indices, \\@lengths, $out_fh);\n}\n\nsub lzss_decompression ($fh) {\n    my ($uncompressed, $indices, $lengths) = deflate_decode($fh);\n    lz77_decompression($uncompressed, $indices, $lengths);\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my @chunk_bytes = unpack('C*', $chunk);\n    my $data        = pack('C*', @{rle4_encode(\\@chunk_bytes)});\n\n    my ($bwt, $idx) = bwt_encode($data);\n\n    my @bytes    = unpack('C*', $bwt);\n    my @alphabet = sort { $a <=> $b } uniq(@bytes);\n\n    my $enc_bytes = mtf_encode(\\@bytes, [@alphabet]);\n\n    if (max(@$enc_bytes) < 255) {\n        print $out_fh chr(1);\n        $enc_bytes = rle_encode($enc_bytes);\n    }\n    else {\n        print $out_fh chr(0);\n        $enc_bytes = rle4_encode($enc_bytes);\n    }\n\n    print $out_fh pack('N', $idx);\n    print $out_fh encode_alphabet(\\@alphabet);\n    lzss_compression(pack('C*', @$enc_bytes), $out_fh);\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $rle_encoded = ord(getc($fh) // die \"error\");\n    my $idx         = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    my $alphabet    = decode_alphabet($fh);\n\n    my $dec   = lzss_decompression($fh);\n    my $bytes = [unpack('C*', $dec)];\n\n    if ($rle_encoded) {\n        $bytes = rle_decode($bytes);\n    }\n    else {\n        $bytes = rle4_decode($bytes);\n    }\n\n    $bytes = mtf_decode($bytes, [@$alphabet]);\n\n    print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode(pack('C*', @$bytes), $idx))])});\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/bwlza2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 June 2023\n# Edit: 19 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + LZ77 compression (LZHD variant) + Arithmetic Coding (in fixed bits).\n\n# Encoding the distances using a DEFLATE-like approach.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n#\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n#\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq sum);\n\nuse constant {\n    PKGNAME => 'BWLZA2',\n    VERSION => '0.01',\n    FORMAT  => 'bwlza2',\n\n    CHUNK_SIZE    => 1 << 17,    # higher value = better compression\n    LOOKAHEAD_LEN => 128,\n};\n\n# Arithmetic Coding settings\nuse constant BITS => 32;\nuse constant MAX  => oct('0b' . ('1' x BITS));\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\n# [distance value, offset bits]\nmy @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4);\n\nuntil ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) {\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n}\n\nmy @DISTANCE_INDICES;\n\nforeach my $i (0 .. $#DISTANCE_SYMBOLS) {\n    my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        last if ($k > CHUNK_SIZE);\n        $DISTANCE_INDICES[$k] = $i;\n    }\n}\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n < 255\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        --$n;\n        push @$indices,      $la - $p;\n        push @$lengths,      $n;\n        push @$uncompressed, ord($chars[$la + $n]);\n        $la += $n + 1;\n        $prefix .= $token;\n    }\n\n    return;\n}\n\nsub lz77_decompression ($uncompressed, $indices, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#{$uncompressed}) {\n        $chunk .= substr($chunk, $offset - $indices->[$i], $lengths->[$i]) . chr($uncompressed->[$i]);\n        $offset += $lengths->[$i] + 1;\n    }\n\n    return $chunk;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub create_cfreq ($freq) {\n\n    my @cf;\n    my $T = 0;\n\n    foreach my $i (sort { $a <=> $b } keys %$freq) {\n        $freq->{$i} // next;\n        $cf[$i] = $T;\n        $T += $freq->{$i};\n        $cf[$i + 1] = $T;\n    }\n\n    return (\\@cf, $T);\n}\n\nsub ac_encode ($bytes_arr) {\n\n    my $enc        = '';\n    my $EOF_SYMBOL = (max(@$bytes_arr) // 0) + 1;\n    my @bytes      = (@$bytes_arr, $EOF_SYMBOL);\n\n    my %freq;\n    ++$freq{$_} for @bytes;\n\n    my ($cf, $T) = create_cfreq(\\%freq);\n\n    if ($T > MAX) {\n        die \"Too few bits: $T > ${\\MAX}\";\n    }\n\n    my $low      = 0;\n    my $high     = MAX;\n    my $uf_count = 0;\n\n    foreach my $c (@bytes) {\n\n        my $w = $high - $low + 1;\n\n        $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$c]) / $T)) & MAX;\n\n        if ($high > MAX) {\n            die \"high > MAX: $high > ${\\MAX}\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n\n                my $bit = $high >> (BITS - 1);\n                $enc .= $bit;\n\n                if ($uf_count > 0) {\n                    $enc .= join('', 1 - $bit) x $uf_count;\n                    $uf_count = 0;\n                }\n\n                $low <<= 1;\n                ($high <<= 1) |= 1;\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                ++$uf_count;\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n        }\n    }\n\n    $enc .= '0';\n    $enc .= '1';\n\n    while (length($enc) % 8 != 0) {\n        $enc .= '1';\n    }\n\n    return ($enc, \\%freq);\n}\n\nsub ac_decode ($fh, $freq) {\n\n    my ($cf, $T) = create_cfreq($freq);\n\n    my @dec;\n    my $low  = 0;\n    my $high = MAX;\n    my $enc  = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS);\n\n    my @table;\n    foreach my $i (sort { $a <=> $b } keys %$freq) {\n        foreach my $j ($cf->[$i] .. $cf->[$i + 1] - 1) {\n            $table[$j] = $i;\n        }\n    }\n\n    my $EOF_SYMBOL = max(keys %$freq) // 0;\n\n    while (1) {\n\n        my $w  = $high - $low + 1;\n        my $ss = int((($T * ($enc - $low + 1)) - 1) / $w);\n\n        my $i = $table[$ss] // last;\n        last if ($i == $EOF_SYMBOL);\n\n        push @dec, $i;\n\n        $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$i]) / $T)) & MAX;\n\n        if ($high > MAX) {\n            die \"error\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n                ($high <<= 1) |= 1;\n                $low <<= 1;\n                ($enc <<= 1) |= (getc($fh) // 1);\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1);\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n            $enc  &= MAX;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub create_ac_entry ($bytes, $out_fh) {\n\n    my ($enc, $freq) = ac_encode($bytes);\n    my $max_symbol = max(keys %$freq) // 0;\n\n    my @freqs;\n    foreach my $k (0 .. $max_symbol) {\n        push @freqs, $freq->{$k} // 0;\n    }\n\n    push @freqs, length($enc) >> 3;\n\n    say \"Max symbol: $max_symbol\";\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_ac_entry ($fh) {\n\n    my @freqs    = @{delta_decode($fh)};\n    my $bits_len = pop(@freqs);\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    say \"Encoded length: $bits_len\";\n    my $bits = read_bits($fh, $bits_len << 3);\n\n    if ($bits_len > 0) {\n        open my $bits_fh, '<:raw', \\$bits;\n        return ac_decode($bits_fh, \\%freq);\n    }\n\n    return [];\n}\n\nsub encode_distances ($distances, $out_fh) {\n\n    my @symbols;\n    my $offset_bits = '';\n\n    foreach my $dist (@$distances) {\n\n        my $i = $DISTANCE_INDICES[$dist];\n        my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n\n        push @symbols, $i;\n\n        if ($bits > 0) {\n            $offset_bits .= sprintf('%0*b', $bits, $dist - $min);\n        }\n    }\n\n    create_ac_entry(\\@symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n}\n\nsub decode_distances ($fh) {\n\n    my $symbols  = decode_ac_entry($fh);\n    my $bits_len = 0;\n\n    foreach my $i (@$symbols) {\n        $bits_len += $DISTANCE_SYMBOLS[$i][1];\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @distances;\n    foreach my $i (@$symbols) {\n        push @distances, $DISTANCE_SYMBOLS[$i][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$i][1], ''));\n    }\n\n    return \\@distances;\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 254 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        if ($enc == 0) {\n            $populated <<= 1;\n        }\n        else {\n            ($populated <<= 1) |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta);\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh) // die \"error\")));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\nsub lzhd_compression ($chunk, $out_fh) {\n    my (@uncompressed, @indices, @lengths);\n    lz77_compression($chunk, \\@uncompressed, \\@indices, \\@lengths);\n\n    my $est_ratio = length($chunk) / (4 * scalar(@uncompressed));\n\n    say(scalar(@uncompressed), ' -> ', $est_ratio);\n\n    create_ac_entry(\\@uncompressed, $out_fh);\n    create_ac_entry(\\@lengths,      $out_fh);\n    encode_distances(\\@indices, $out_fh);\n}\n\nsub lzhd_decompression ($fh) {\n\n    my $uncompressed = decode_ac_entry($fh);\n    my $lengths      = decode_ac_entry($fh);\n    my $indices      = decode_distances($fh);\n\n    return lz77_decompression($uncompressed, $indices, $lengths);\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my @chunk_bytes = unpack('C*', $chunk);\n    my $data        = pack('C*', @{rle4_encode(\\@chunk_bytes)});\n\n    my ($bwt, $idx) = bwt_encode($data);\n\n    my @bytes    = unpack('C*', $bwt);\n    my @alphabet = sort { $a <=> $b } uniq(@bytes);\n\n    my $enc_bytes = mtf_encode(\\@bytes, [@alphabet]);\n\n    if (max(@$enc_bytes) < 255) {\n        print $out_fh chr(1);\n        $enc_bytes = rle_encode($enc_bytes);\n    }\n    else {\n        print $out_fh chr(0);\n        $enc_bytes = rle4_encode($enc_bytes);\n    }\n\n    print $out_fh pack('N', $idx);\n    print $out_fh encode_alphabet(\\@alphabet);\n    lzhd_compression(pack('C*', @$enc_bytes), $out_fh);\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $rle_encoded = ord(getc($fh) // die \"error\");\n    my $idx         = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    my $alphabet    = decode_alphabet($fh);\n\n    my $bytes = [unpack('C*', lzhd_decompression($fh))];\n\n    if ($rle_encoded) {\n        $bytes = rle_decode($bytes);\n    }\n    else {\n        $bytes = rle4_decode($bytes);\n    }\n\n    $bytes = mtf_decode($bytes, [@$alphabet]);\n\n    print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode(pack('C*', @$bytes), $idx))])});\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/bwlza_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 June 2023\n# Edit: 06 February 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-front transform (MTF) + LZ77 compression (LZSS) + Arithmetic Coding (in fixed bits).\n\n# Encoding the literals and the pointers using a DEFLATE-like approach.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n#\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n#\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq sum);\nuse POSIX          qw(ceil log2);\n\nuse constant {\n    PKGNAME => 'BWLZA',\n    VERSION => '0.03',\n    FORMAT  => 'bwlza',\n\n    CHUNK_SIZE    => 1 << 17,    # higher value = better compression\n    LOOKAHEAD_LEN => 128,\n};\n\n# Arithmetic Coding settings\nuse constant BITS => 32;\nuse constant MAX  => oct('0b' . ('1' x BITS));\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(3);\n\n# [distance value, offset bits]\nmy @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4);\n\nuntil ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) {\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n}\n\n# [length, offset bits]\nmy @LENGTH_SYMBOLS = ((map { [$_, 0] } (3 .. 10)));\n\n{\n    my $delta = 1;\n    until ($LENGTH_SYMBOLS[-1][0] > 163) {\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1];\n        $delta *= 2;\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n    }\n    push @LENGTH_SYMBOLS, [258, 0];\n}\n\nmy @DISTANCE_INDICES;\n\nforeach my $i (0 .. $#DISTANCE_SYMBOLS) {\n    my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        last if ($k > CHUNK_SIZE);\n        $DISTANCE_INDICES[$k] = $i;\n    }\n}\n\nmy @LENGTH_INDICES;\n\nforeach my $i (0 .. $#LENGTH_SYMBOLS) {\n    my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        $LENGTH_INDICES[$k] = $i;\n    }\n}\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    my $min_len = $LENGTH_SYMBOLS[0][0];\n    my $max_len = $LENGTH_SYMBOLS[-1][0];\n\n    my %literal_freq;\n    my %distance_freq;\n\n    my $literal_count  = 0;\n    my $distance_count = 0;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n <= $max_len\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        my $enc_bits_len     = 0;\n        my $literal_bits_len = 0;\n\n        if ($n > $min_len) {\n\n            my $dist = $DISTANCE_SYMBOLS[$DISTANCE_INDICES[$la - $p]];\n            $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0))));\n\n            my $len_idx = $LENGTH_INDICES[$n - 1];\n            my $len     = $LENGTH_SYMBOLS[$len_idx];\n\n            $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0))));\n\n            my %freq;\n            foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) {\n                ++$freq{$c};\n                $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0))));\n            }\n        }\n\n        if ($n > $min_len and $enc_bits_len < $literal_bits_len) {\n\n            push @$lengths,      $n - 1;\n            push @$indices,      $la - $p;\n            push @$uncompressed, undef;\n\n            my $dist_idx = $DISTANCE_INDICES[$la - $p];\n            my $dist     = $DISTANCE_SYMBOLS[$dist_idx];\n\n            ++$distance_count;\n            ++$distance_freq{$dist->[0]};\n\n            ++$literal_count;\n            ++$literal_freq{$LENGTH_INDICES[$n - 1] + 256};\n\n            $la += $n - 1;\n            $prefix .= substr($token, 0, -1);\n        }\n        else {\n            my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]);\n\n            push @$uncompressed, @bytes;\n            push @$lengths, (0) x scalar(@bytes);\n            push @$indices, (0) x scalar(@bytes);\n\n            ++$literal_freq{$_} for @bytes;\n\n            $literal_count += $n;\n            $la            += $n;\n            $prefix .= $token;\n        }\n    }\n\n    return;\n}\n\nsub lz77_decompression ($literals, $distances, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#$literals) {\n        if ($lengths->[$i] != 0) {\n            $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]);\n            $offset += $lengths->[$i];\n        }\n        else {\n            $chunk .= chr($literals->[$i]);\n            $offset += 1;\n        }\n    }\n\n    return $chunk;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub create_cfreq ($freq) {\n\n    my @cf;\n    my $T = 0;\n\n    foreach my $i (sort { $a <=> $b } keys %$freq) {\n        $freq->{$i} // next;\n        $cf[$i] = $T;\n        $T += $freq->{$i};\n        $cf[$i + 1] = $T;\n    }\n\n    return (\\@cf, $T);\n}\n\nsub ac_encode ($bytes_arr) {\n\n    my $enc        = '';\n    my $EOF_SYMBOL = (max(@$bytes_arr) // 0) + 1;\n    my @bytes      = (@$bytes_arr, $EOF_SYMBOL);\n\n    my %freq;\n    ++$freq{$_} for @bytes;\n\n    my ($cf, $T) = create_cfreq(\\%freq);\n\n    if ($T > MAX) {\n        die \"Too few bits: $T > ${\\MAX}\";\n    }\n\n    my $low      = 0;\n    my $high     = MAX;\n    my $uf_count = 0;\n\n    foreach my $c (@bytes) {\n\n        my $w = $high - $low + 1;\n\n        $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$c]) / $T)) & MAX;\n\n        if ($high > MAX) {\n            die \"high > MAX: $high > ${\\MAX}\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n\n                my $bit = $high >> (BITS - 1);\n                $enc .= $bit;\n\n                if ($uf_count > 0) {\n                    $enc .= join('', 1 - $bit) x $uf_count;\n                    $uf_count = 0;\n                }\n\n                $low <<= 1;\n                ($high <<= 1) |= 1;\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                ++$uf_count;\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n        }\n    }\n\n    $enc .= '0';\n    $enc .= '1';\n\n    while (length($enc) % 8 != 0) {\n        $enc .= '1';\n    }\n\n    return ($enc, \\%freq);\n}\n\nsub ac_decode ($fh, $freq) {\n\n    my ($cf, $T) = create_cfreq($freq);\n\n    my @dec;\n    my $low  = 0;\n    my $high = MAX;\n    my $enc  = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS);\n\n    my @table;\n    foreach my $i (sort { $a <=> $b } keys %$freq) {\n        foreach my $j ($cf->[$i] .. $cf->[$i + 1] - 1) {\n            $table[$j] = $i;\n        }\n    }\n\n    my $EOF_SYMBOL = max(keys %$freq) // 0;\n\n    while (1) {\n\n        my $w  = $high - $low + 1;\n        my $ss = int((($T * ($enc - $low + 1)) - 1) / $w);\n\n        my $i = $table[$ss] // last;\n        last if ($i == $EOF_SYMBOL);\n\n        push @dec, $i;\n\n        $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$i]) / $T)) & MAX;\n\n        if ($high > MAX) {\n            die \"error\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n                ($high <<= 1) |= 1;\n                $low <<= 1;\n                ($enc <<= 1) |= (getc($fh) // 1);\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1);\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n            $enc  &= MAX;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub create_ac_entry ($bytes, $out_fh) {\n\n    my ($enc, $freq) = ac_encode($bytes);\n    my $max_symbol = max(keys %$freq) // 0;\n\n    my @freqs;\n    foreach my $k (0 .. $max_symbol) {\n        push @freqs, $freq->{$k} // 0;\n    }\n\n    push @freqs, length($enc) >> 3;\n\n    say \"Max symbol: $max_symbol\";\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_ac_entry ($fh) {\n\n    my @freqs    = @{delta_decode($fh)};\n    my $bits_len = pop(@freqs);\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    say \"Encoded length: $bits_len\";\n    my $bits = read_bits($fh, $bits_len << 3);\n\n    if ($bits_len > 0) {\n        open my $bits_fh, '<:raw', \\$bits;\n        return ac_decode($bits_fh, \\%freq);\n    }\n\n    return [];\n}\n\nsub deflate_encode ($literals, $distances, $lengths, $out_fh) {\n\n    my @len_symbols;\n    my @dist_symbols;\n    my $offset_bits = '';\n\n    foreach my $j (0 .. $#{$literals}) {\n\n        if ($lengths->[$j] == 0) {\n            push @len_symbols, $literals->[$j];\n            next;\n        }\n\n        my $len  = $lengths->[$j];\n        my $dist = $distances->[$j];\n\n        {\n            my $len_idx = $LENGTH_INDICES[$len];\n            my ($min, $bits) = @{$LENGTH_SYMBOLS[$len_idx]};\n\n            push @len_symbols, $len_idx + 256;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $len - $min);\n            }\n        }\n\n        {\n            my $dist_idx = $DISTANCE_INDICES[$dist];\n            my ($min, $bits) = @{$DISTANCE_SYMBOLS[$dist_idx]};\n\n            push @dist_symbols, $dist_idx;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $dist - $min);\n            }\n        }\n    }\n\n    create_ac_entry(\\@len_symbols,  $out_fh);\n    create_ac_entry(\\@dist_symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n}\n\nsub deflate_decode ($fh) {\n\n    my $len_symbols  = decode_ac_entry($fh);\n    my $dist_symbols = decode_ac_entry($fh);\n\n    my $bits_len = 0;\n\n    foreach my $i (@$dist_symbols) {\n        $bits_len += $DISTANCE_SYMBOLS[$i][1];\n    }\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            $bits_len += $LENGTH_SYMBOLS[$i - 256][1];\n        }\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @literals;\n    my @lengths;\n    my @distances;\n\n    my $j = 0;\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            my $dist = $dist_symbols->[$j++];\n            push @literals,  undef;\n            push @lengths,   $LENGTH_SYMBOLS[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS[$i - 256][1], ''));\n            push @distances, $DISTANCE_SYMBOLS[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$dist][1], ''));\n        }\n        else {\n            push @literals,  $i;\n            push @lengths,   0;\n            push @distances, 0;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 254 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        if ($enc == 0) {\n            $populated <<= 1;\n        }\n        else {\n            ($populated <<= 1) |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta);\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh) // die \"error\")));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\nsub lzss_compression ($data, $out_fh) {\n    my (@uncompressed, @indices, @lengths);\n    lz77_compression($data, \\@uncompressed, \\@indices, \\@lengths);\n\n    my $est_ratio = length($data) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices));\n    say \"\\nEst. ratio: \", $est_ratio, \" (\", scalar(@uncompressed), \" uncompressed bytes)\";\n\n    deflate_encode(\\@uncompressed, \\@indices, \\@lengths, $out_fh);\n}\n\nsub lzss_decompression ($fh) {\n    my ($uncompressed, $indices, $lengths) = deflate_decode($fh);\n    lz77_decompression($uncompressed, $indices, $lengths);\n}\n\nsub compression ($chunk, $out_fh) {\n    my @chunk_bytes = unpack('C*', $chunk);\n    my $data        = pack('C*', @{rle4_encode(\\@chunk_bytes)});\n\n    my ($bwt, $idx) = bwt_encode($data);\n\n    my @bytes    = unpack('C*', $bwt);\n    my @alphabet = sort { $a <=> $b } uniq(@bytes);\n\n    my $enc_bytes = mtf_encode(\\@bytes, [@alphabet]);\n\n    if (max(@$enc_bytes) < 255) {\n        print $out_fh chr(1);\n        $enc_bytes = rle_encode($enc_bytes);\n    }\n    else {\n        print $out_fh chr(0);\n        $enc_bytes = rle4_encode($enc_bytes);\n    }\n\n    print $out_fh pack('N', $idx);\n    print $out_fh encode_alphabet(\\@alphabet);\n    lzss_compression(pack('C*', @$enc_bytes), $out_fh);\n}\n\nsub decompression ($fh, $out_fh) {\n    my $rle_encoded = ord(getc($fh) // die \"error\");\n    my $idx         = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    my $alphabet    = decode_alphabet($fh);\n\n    my $dec   = lzss_decompression($fh);\n    my $bytes = [unpack('C*', $dec)];\n\n    if ($rle_encoded) {\n        $bytes = rle_decode($bytes);\n    }\n    else {\n        $bytes = rle4_decode($bytes);\n    }\n\n    $bytes = mtf_decode($bytes, [@$alphabet]);\n\n    print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode(pack('C*', @$bytes), $idx))])});\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/bwlzad2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 June 2023\n# Edit: 19 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-front transform (MTF) + LZ77 compression (LZHD variant) + Adaptive Arithmetic Coding (in fixed bits).\n\n# Encoding the distances using a DEFLATE-like approach.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n#\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n#\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq sum);\n\nuse constant {\n    PKGNAME => 'BWLZAD2',\n    VERSION => '0.01',\n    FORMAT  => 'bwlzad2',\n\n    CHUNK_SIZE    => 1 << 17,    # higher value = better compression\n    LOOKAHEAD_LEN => 128,\n};\n\n# Arithmetic Coding settings\nuse constant BITS         => 32;\nuse constant MAX          => oct('0b' . ('1' x BITS));\nuse constant INITIAL_FREQ => 1;\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\n# [distance value, offset bits]\nmy @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4);\n\nuntil ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) {\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n}\n\nmy @DISTANCE_INDICES;\n\nforeach my $i (0 .. $#DISTANCE_SYMBOLS) {\n    my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        last if ($k > CHUNK_SIZE);\n        $DISTANCE_INDICES[$k] = $i;\n    }\n}\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n < 255\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        --$n;\n        push @$indices,      $la - $p;\n        push @$lengths,      $n;\n        push @$uncompressed, ord($chars[$la + $n]);\n        $la += $n + 1;\n        $prefix .= $token;\n    }\n\n    return;\n}\n\nsub lz77_decompression ($uncompressed, $indices, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#{$uncompressed}) {\n        $chunk .= substr($chunk, $offset - $indices->[$i], $lengths->[$i]) . chr($uncompressed->[$i]);\n        $offset += $lengths->[$i] + 1;\n    }\n\n    return $chunk;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub create_cfreq ($freq_value, $max_symbol) {\n\n    my $T = 0;\n    my (@cf, @freq);\n\n    foreach my $i (0 .. $max_symbol) {\n        $freq[$i] = $freq_value;\n        $cf[$i]   = $T;\n        $T += $freq_value;\n        $cf[$i + 1] = $T;\n    }\n\n    return (\\@freq, \\@cf, $T);\n}\n\nsub increment_freq ($c, $max_symbol, $freq, $cf) {\n\n    ++$freq->[$c];\n    my $T = $cf->[$c];\n\n    foreach my $i ($c .. $max_symbol) {\n        $cf->[$i] = $T;\n        $T += $freq->[$i];\n        $cf->[$i + 1] = $T;\n    }\n\n    return $T;\n}\n\nsub ac_encode ($bytes_arr) {\n\n    my $enc   = '';\n    my @bytes = (@$bytes_arr, (max(@$bytes_arr) // 0) + 1);\n\n    my $max_symbol = max(@bytes) // 0;\n    my ($freq, $cf, $T) = create_cfreq(INITIAL_FREQ, $max_symbol);\n\n    if ($T > MAX) {\n        die \"Too few bits: $T > ${\\MAX}\";\n    }\n\n    my $low      = 0;\n    my $high     = MAX;\n    my $uf_count = 0;\n\n    foreach my $c (@bytes) {\n\n        my $w = $high - $low + 1;\n\n        $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$c]) / $T)) & MAX;\n\n        $T = increment_freq($c, $max_symbol, $freq, $cf);\n\n        if ($high > MAX) {\n            die \"high > MAX: $high > ${\\MAX}\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n\n                my $bit = $high >> (BITS - 1);\n                $enc .= $bit;\n\n                if ($uf_count > 0) {\n                    $enc .= join('', 1 - $bit) x $uf_count;\n                    $uf_count = 0;\n                }\n\n                $low <<= 1;\n                ($high <<= 1) |= 1;\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                ++$uf_count;\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n        }\n    }\n\n    $enc .= '0';\n    $enc .= '1';\n\n    while (length($enc) % 8 != 0) {\n        $enc .= '1';\n    }\n\n    return ($enc, $max_symbol);\n}\n\nsub ac_decode ($fh, $max_symbol) {\n\n    my ($freq, $cf, $T) = create_cfreq(INITIAL_FREQ, $max_symbol);\n\n    my @dec;\n    my $low  = 0;\n    my $high = MAX;\n\n    my $enc = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS);\n\n    while (1) {\n        my $w  = ($high + 1) - $low;\n        my $ss = int((($T * ($enc - $low + 1)) - 1) / $w);\n\n        my $i = 0;\n        foreach my $j (0 .. $max_symbol) {\n            if ($cf->[$j] <= $ss and $ss < $cf->[$j + 1]) {\n                $i = $j;\n                last;\n            }\n        }\n\n        last if ($i == $max_symbol);\n        push @dec, $i;\n\n        $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$i]) / $T)) & MAX;\n\n        $T = increment_freq($i, $max_symbol, $freq, $cf);\n\n        if ($high > MAX) {\n            die \"high > MAX: ($high > ${\\MAX})\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n                ($high <<= 1) |= 1;\n                $low <<= 1;\n                ($enc <<= 1) |= (getc($fh) // 1);\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1);\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n            $enc  &= MAX;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub create_ac_entry ($bytes, $out_fh) {\n\n    my ($enc, $max_symbol) = ac_encode($bytes);\n\n    print $out_fh delta_encode([$max_symbol, length($enc)], 1);\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_ac_entry ($fh) {\n\n    my ($max_symbol, $enc_len) = @{delta_decode($fh, 1)};\n\n    say \"Encoded length: $enc_len\";\n\n    if ($enc_len > 0) {\n        my $bits = read_bits($fh, $enc_len);\n        open my $bits_fh, '<:raw', \\$bits;\n        return ac_decode($bits_fh, $max_symbol);\n    }\n\n    return [];\n}\n\nsub encode_distances ($distances, $out_fh) {\n\n    my @symbols;\n    my $offset_bits = '';\n\n    foreach my $dist (@$distances) {\n\n        my $i = $DISTANCE_INDICES[$dist];\n        my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n\n        push @symbols, $i;\n\n        if ($bits > 0) {\n            $offset_bits .= sprintf('%0*b', $bits, $dist - $min);\n        }\n    }\n\n    create_ac_entry(\\@symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n}\n\nsub decode_distances ($fh) {\n\n    my $symbols  = decode_ac_entry($fh);\n    my $bits_len = 0;\n\n    foreach my $i (@$symbols) {\n        $bits_len += $DISTANCE_SYMBOLS[$i][1];\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @distances;\n    foreach my $i (@$symbols) {\n        push @distances, $DISTANCE_SYMBOLS[$i][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$i][1], ''));\n    }\n\n    return \\@distances;\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 254 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        if ($enc == 0) {\n            $populated <<= 1;\n        }\n        else {\n            ($populated <<= 1) |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta);\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh) // die \"error\")));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\nsub lzhd_compression ($chunk, $out_fh) {\n    my (@uncompressed, @indices, @lengths);\n    lz77_compression($chunk, \\@uncompressed, \\@indices, \\@lengths);\n\n    my $est_ratio = length($chunk) / (4 * scalar(@uncompressed));\n\n    say(scalar(@uncompressed), ' -> ', $est_ratio);\n\n    create_ac_entry(\\@uncompressed, $out_fh);\n    create_ac_entry(\\@lengths,      $out_fh);\n    encode_distances(\\@indices, $out_fh);\n}\n\nsub lzhd_decompression ($fh) {\n\n    my $uncompressed = decode_ac_entry($fh);\n    my $lengths      = decode_ac_entry($fh);\n    my $indices      = decode_distances($fh);\n\n    return lz77_decompression($uncompressed, $indices, $lengths);\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my @chunk_bytes = unpack('C*', $chunk);\n    my $data        = pack('C*', @{rle4_encode(\\@chunk_bytes)});\n\n    my ($bwt, $idx) = bwt_encode($data);\n\n    my @bytes    = unpack('C*', $bwt);\n    my @alphabet = sort { $a <=> $b } uniq(@bytes);\n\n    my $enc_bytes = mtf_encode(\\@bytes, [@alphabet]);\n\n    if (max(@$enc_bytes) < 255) {\n        print $out_fh chr(1);\n        $enc_bytes = rle_encode($enc_bytes);\n    }\n    else {\n        print $out_fh chr(0);\n        $enc_bytes = rle4_encode($enc_bytes);\n    }\n\n    print $out_fh pack('N', $idx);\n    print $out_fh encode_alphabet(\\@alphabet);\n    lzhd_compression(pack('C*', @$enc_bytes), $out_fh);\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $rle_encoded = ord(getc($fh) // die \"error\");\n    my $idx         = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    my $alphabet    = decode_alphabet($fh);\n\n    my $bytes = [unpack('C*', lzhd_decompression($fh))];\n\n    if ($rle_encoded) {\n        $bytes = rle_decode($bytes);\n    }\n    else {\n        $bytes = rle4_decode($bytes);\n    }\n\n    $bytes = mtf_decode($bytes, [@$alphabet]);\n\n    print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode(pack('C*', @$bytes), $idx))])});\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/bwlzad_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 June 2023\n# Edit: 07 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-front transform (MTF) + LZ77 compression (LZSS) + Adaptive Arithmetic Coding (in fixed bits).\n\n# Encoding the literals and the pointers using a DEFLATE-like approach.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n#\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n#\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq sum);\nuse POSIX          qw(ceil log2);\n\nuse constant {\n    PKGNAME => 'BWLZAD',\n    VERSION => '0.01',\n    FORMAT  => 'bwlzad',\n\n    CHUNK_SIZE    => 1 << 17,    # higher value = better compression\n    LOOKAHEAD_LEN => 128,\n};\n\n# Arithmetic Coding settings\nuse constant BITS         => 32;\nuse constant MAX          => oct('0b' . ('1' x BITS));\nuse constant INITIAL_FREQ => 1;\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\n# [distance value, offset bits]\nmy @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4);\n\nuntil ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) {\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n}\n\n# [length, offset bits]\nmy @LENGTH_SYMBOLS = ((map { [$_, 0] } (3 .. 10)));\n\n{\n    my $delta = 1;\n    until ($LENGTH_SYMBOLS[-1][0] > 163) {\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1];\n        $delta *= 2;\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n    }\n    push @LENGTH_SYMBOLS, [258, 0];\n}\n\nmy @DISTANCE_INDICES;\n\nforeach my $i (0 .. $#DISTANCE_SYMBOLS) {\n    my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        last if ($k > CHUNK_SIZE);\n        $DISTANCE_INDICES[$k] = $i;\n    }\n}\n\nmy @LENGTH_INDICES;\n\nforeach my $i (0 .. $#LENGTH_SYMBOLS) {\n    my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        $LENGTH_INDICES[$k] = $i;\n    }\n}\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    my $min_len = $LENGTH_SYMBOLS[0][0];\n    my $max_len = $LENGTH_SYMBOLS[-1][0];\n\n    my %literal_freq;\n    my %distance_freq;\n\n    my $literal_count  = 0;\n    my $distance_count = 0;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n <= $max_len\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        my $enc_bits_len     = 0;\n        my $literal_bits_len = 0;\n\n        if ($n > $min_len) {\n\n            my $dist = $DISTANCE_SYMBOLS[$DISTANCE_INDICES[$la - $p]];\n            $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0))));\n\n            my $len_idx = $LENGTH_INDICES[$n - 1];\n            my $len     = $LENGTH_SYMBOLS[$len_idx];\n\n            $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0))));\n\n            my %freq;\n            foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) {\n                ++$freq{$c};\n                $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0))));\n            }\n        }\n\n        if ($n > $min_len and $enc_bits_len < $literal_bits_len) {\n\n            push @$lengths,      $n - 1;\n            push @$indices,      $la - $p;\n            push @$uncompressed, undef;\n\n            my $dist_idx = $DISTANCE_INDICES[$la - $p];\n            my $dist     = $DISTANCE_SYMBOLS[$dist_idx];\n\n            ++$distance_count;\n            ++$distance_freq{$dist->[0]};\n\n            ++$literal_count;\n            ++$literal_freq{$LENGTH_INDICES[$n - 1] + 256};\n\n            $la += $n - 1;\n            $prefix .= substr($token, 0, -1);\n        }\n        else {\n            my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]);\n\n            push @$uncompressed, @bytes;\n            push @$lengths, (0) x scalar(@bytes);\n            push @$indices, (0) x scalar(@bytes);\n\n            ++$literal_freq{$_} for @bytes;\n\n            $literal_count += $n;\n            $la            += $n;\n            $prefix .= $token;\n        }\n    }\n\n    return;\n}\n\nsub lz77_decompression ($literals, $distances, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#$literals) {\n        if ($lengths->[$i] != 0) {\n            $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]);\n            $offset += $lengths->[$i];\n        }\n        else {\n            $chunk .= chr($literals->[$i]);\n            $offset += 1;\n        }\n    }\n\n    return $chunk;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub create_cfreq ($freq_value, $max_symbol) {\n\n    my $T = 0;\n    my (@cf, @freq);\n\n    foreach my $i (0 .. $max_symbol) {\n        $freq[$i] = $freq_value;\n        $cf[$i]   = $T;\n        $T += $freq_value;\n        $cf[$i + 1] = $T;\n    }\n\n    return (\\@freq, \\@cf, $T);\n}\n\nsub increment_freq ($c, $max_symbol, $freq, $cf) {\n\n    ++$freq->[$c];\n    my $T = $cf->[$c];\n\n    foreach my $i ($c .. $max_symbol) {\n        $cf->[$i] = $T;\n        $T += $freq->[$i];\n        $cf->[$i + 1] = $T;\n    }\n\n    return $T;\n}\n\nsub ac_encode ($bytes_arr) {\n\n    my $enc   = '';\n    my @bytes = (@$bytes_arr, (max(@$bytes_arr) // 0) + 1);\n\n    my $max_symbol = max(@bytes) // 0;\n    my ($freq, $cf, $T) = create_cfreq(INITIAL_FREQ, $max_symbol);\n\n    if ($T > MAX) {\n        die \"Too few bits: $T > ${\\MAX}\";\n    }\n\n    my $low      = 0;\n    my $high     = MAX;\n    my $uf_count = 0;\n\n    foreach my $c (@bytes) {\n\n        my $w = $high - $low + 1;\n\n        $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$c]) / $T)) & MAX;\n\n        $T = increment_freq($c, $max_symbol, $freq, $cf);\n\n        if ($high > MAX) {\n            die \"high > MAX: $high > ${\\MAX}\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n\n                my $bit = $high >> (BITS - 1);\n                $enc .= $bit;\n\n                if ($uf_count > 0) {\n                    $enc .= join('', 1 - $bit) x $uf_count;\n                    $uf_count = 0;\n                }\n\n                $low <<= 1;\n                ($high <<= 1) |= 1;\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                ++$uf_count;\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n        }\n    }\n\n    $enc .= '0';\n    $enc .= '1';\n\n    while (length($enc) % 8 != 0) {\n        $enc .= '1';\n    }\n\n    return ($enc, $max_symbol);\n}\n\nsub ac_decode ($fh, $max_symbol) {\n\n    my ($freq, $cf, $T) = create_cfreq(INITIAL_FREQ, $max_symbol);\n\n    my @dec;\n    my $low  = 0;\n    my $high = MAX;\n\n    my $enc = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS);\n\n    while (1) {\n        my $w  = ($high + 1) - $low;\n        my $ss = int((($T * ($enc - $low + 1)) - 1) / $w);\n\n        my $i = 0;\n        foreach my $j (0 .. $max_symbol) {\n            if ($cf->[$j] <= $ss and $ss < $cf->[$j + 1]) {\n                $i = $j;\n                last;\n            }\n        }\n\n        last if ($i == $max_symbol);\n        push @dec, $i;\n\n        $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$i]) / $T)) & MAX;\n\n        $T = increment_freq($i, $max_symbol, $freq, $cf);\n\n        if ($high > MAX) {\n            die \"high > MAX: ($high > ${\\MAX})\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n                ($high <<= 1) |= 1;\n                $low <<= 1;\n                ($enc <<= 1) |= (getc($fh) // 1);\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1);\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n            $enc  &= MAX;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub create_ac_entry ($bytes, $out_fh) {\n\n    my ($enc, $max_symbol) = ac_encode($bytes);\n\n    print $out_fh delta_encode([$max_symbol, length($enc)], 1);\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_ac_entry ($fh) {\n\n    my ($max_symbol, $enc_len) = @{delta_decode($fh, 1)};\n\n    say \"Encoded length: $enc_len\";\n\n    if ($enc_len > 0) {\n        my $bits = read_bits($fh, $enc_len);\n        open my $bits_fh, '<:raw', \\$bits;\n        return ac_decode($bits_fh, $max_symbol);\n    }\n\n    return [];\n}\n\nsub deflate_encode ($literals, $distances, $lengths, $out_fh) {\n\n    my @len_symbols;\n    my @dist_symbols;\n    my $offset_bits = '';\n\n    foreach my $j (0 .. $#{$literals}) {\n\n        if ($lengths->[$j] == 0) {\n            push @len_symbols, $literals->[$j];\n            next;\n        }\n\n        my $len  = $lengths->[$j];\n        my $dist = $distances->[$j];\n\n        {\n            my $len_idx = $LENGTH_INDICES[$len];\n            my ($min, $bits) = @{$LENGTH_SYMBOLS[$len_idx]};\n\n            push @len_symbols, $len_idx + 256;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $len - $min);\n            }\n        }\n\n        {\n            my $dist_idx = $DISTANCE_INDICES[$dist];\n            my ($min, $bits) = @{$DISTANCE_SYMBOLS[$dist_idx]};\n\n            push @dist_symbols, $dist_idx;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $dist - $min);\n            }\n        }\n    }\n\n    create_ac_entry(\\@len_symbols,  $out_fh);\n    create_ac_entry(\\@dist_symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n}\n\nsub deflate_decode ($fh) {\n\n    my $len_symbols  = decode_ac_entry($fh);\n    my $dist_symbols = decode_ac_entry($fh);\n\n    my $bits_len = 0;\n\n    foreach my $i (@$dist_symbols) {\n        $bits_len += $DISTANCE_SYMBOLS[$i][1];\n    }\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            $bits_len += $LENGTH_SYMBOLS[$i - 256][1];\n        }\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @literals;\n    my @lengths;\n    my @distances;\n\n    my $j = 0;\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            my $dist = $dist_symbols->[$j++];\n            push @literals,  undef;\n            push @lengths,   $LENGTH_SYMBOLS[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS[$i - 256][1], ''));\n            push @distances, $DISTANCE_SYMBOLS[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$dist][1], ''));\n        }\n        else {\n            push @literals,  $i;\n            push @lengths,   0;\n            push @distances, 0;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 254 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        if ($enc == 0) {\n            $populated <<= 1;\n        }\n        else {\n            ($populated <<= 1) |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta);\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh) // die \"error\")));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\nsub lzss_compression ($chunk, $out_fh) {\n    my (@uncompressed, @indices, @lengths);\n    lz77_compression($chunk, \\@uncompressed, \\@indices, \\@lengths);\n\n    my $est_ratio = length($chunk) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices));\n    say \"\\nEst. ratio: \", $est_ratio, \" (\", scalar(@uncompressed), \" uncompressed bytes)\";\n    deflate_encode(\\@uncompressed, \\@indices, \\@lengths, $out_fh);\n}\n\nsub lzss_decompression ($fh) {\n    my ($uncompressed, $indices, $lengths) = deflate_decode($fh);\n    lz77_decompression($uncompressed, $indices, $lengths);\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my @chunk_bytes = unpack('C*', $chunk);\n    my $data        = pack('C*', @{rle4_encode(\\@chunk_bytes)});\n\n    my ($bwt, $idx) = bwt_encode($data);\n\n    my @bytes    = unpack('C*', $bwt);\n    my @alphabet = sort { $a <=> $b } uniq(@bytes);\n\n    my $enc_bytes = mtf_encode(\\@bytes, [@alphabet]);\n\n    if (max(@$enc_bytes) < 255) {\n        print $out_fh chr(1);\n        $enc_bytes = rle_encode($enc_bytes);\n    }\n    else {\n        print $out_fh chr(0);\n        $enc_bytes = rle4_encode($enc_bytes);\n    }\n\n    print $out_fh pack('N', $idx);\n    print $out_fh encode_alphabet(\\@alphabet);\n    lzss_compression(pack('C*', @$enc_bytes), $out_fh);\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $rle_encoded = ord(getc($fh) // die \"error\");\n    my $idx         = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    my $alphabet    = decode_alphabet($fh);\n\n    my $bytes = [unpack('C*', lzss_decompression($fh))];\n\n    if ($rle_encoded) {\n        $bytes = rle_decode($bytes);\n    }\n    else {\n        $bytes = rle4_decode($bytes);\n    }\n\n    $bytes = mtf_decode($bytes, [@$alphabet]);\n\n    print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode(pack('C*', @$bytes), $idx))])});\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/bwlzhd_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# Edit: 19 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler transform (BWT) + Run-length Encoding (RLE) + LZ77 compression (LZHD variant) + Huffman coding.\n\n# Encoding the distances/indices using a DEFLATE-like approach.\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max);\n\nuse constant {\n    PKGNAME => 'BWLZHD',\n    VERSION => '0.01',\n    FORMAT  => 'bwlzhd',\n\n    LOOKAHEAD_LEN => 128,\n    CHUNK_SIZE    => 1 << 17,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\n# [distance value, offset bits]\nmy @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4);\n\nuntil ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) {\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n}\n\nmy @DISTANCE_INDICES;\n\nforeach my $i (0 .. $#DISTANCE_SYMBOLS) {\n    my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        last if ($k > CHUNK_SIZE);\n        $DISTANCE_INDICES[$k] = $i;\n    }\n}\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n < 255\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        --$n;\n        push @$indices,      $la - $p;\n        push @$lengths,      $n;\n        push @$uncompressed, ord($chars[$la + $n]);\n        $la += $n + 1;\n        $prefix .= $token;\n    }\n\n    return;\n}\n\nsub lz77_decompression ($uncompressed, $indices, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#{$uncompressed}) {\n        $chunk .= substr($chunk, $offset - $indices->[$i], $lengths->[$i]) . $uncompressed->[$i];\n        $offset += $lengths->[$i] + 1;\n    }\n\n    return $chunk;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1}/gr;    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    foreach my $k (keys %$rev_dict) {\n        $rev_dict->{$k} = chr($rev_dict->{$k});\n    }\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return '';\n}\n\nsub encode_distances ($distances, $out_fh) {\n\n    my @symbols;\n    my $offset_bits = '';\n\n    foreach my $dist (@$distances) {\n\n        my $i = $DISTANCE_INDICES[$dist];\n        my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n\n        push @symbols, $i;\n\n        if ($bits > 0) {\n            $offset_bits .= sprintf('%0*b', $bits, $dist - $min);\n        }\n    }\n\n    create_huffman_entry(\\@symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n}\n\nsub decode_distances ($fh) {\n\n    my @symbols  = unpack('C*', decode_huffman_entry($fh));\n    my $bits_len = 0;\n\n    foreach my $i (@symbols) {\n        $bits_len += $DISTANCE_SYMBOLS[$i][1];\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @distances;\n    foreach my $i (@symbols) {\n        push @distances, $DISTANCE_SYMBOLS[$i][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$i][1], ''));\n    }\n\n    return \\@distances;\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my $rle4 = rle4_encode([unpack('C*', $chunk)]);\n    my ($bwt, $idx) = bwt_encode(pack('C*', @$rle4));\n\n    $bwt = pack('C*', @{rle4_encode([unpack('C*', $bwt)])});\n\n    say \"BWT index = $idx\";\n\n    my (@uncompressed, @indices, @lengths);\n    lz77_compression($bwt, \\@uncompressed, \\@indices, \\@lengths);\n\n    my $est_ratio = length($chunk) / (4 * scalar(@uncompressed));\n\n    say(scalar(@uncompressed), ' -> ', $est_ratio);\n\n    print $out_fh pack('N', $idx);\n    create_huffman_entry(\\@uncompressed, $out_fh);\n    create_huffman_entry(\\@lengths,      $out_fh);\n    encode_distances(\\@indices, $out_fh);\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $idx          = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4));\n    my @uncompressed = split(//, decode_huffman_entry($fh));\n    my @lengths      = unpack('C*', decode_huffman_entry($fh));\n    my $indices      = decode_distances($fh);\n\n    my $rle4 = lz77_decompression(\\@uncompressed, $indices, \\@lengths);\n    my $bwt  = pack('C*', @{rle4_decode([unpack('C*', $rle4)])});\n    my @rle4 = unpack('C*', bwt_decode($bwt, $idx));\n    print $out_fh pack('C*', @{rle4_decode(\\@rle4)});\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/bwlzss_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 June 2023\n# Edit: 19 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + LZ77 compression (LZSS) + Huffman coding.\n\n# Encoding the literals and the pointers using a DEFLATE-like approach.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n#\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\nuse POSIX          qw(ceil log2);\n\nuse constant {\n    PKGNAME => 'BWLZSS',\n    VERSION => '0.01',\n    FORMAT  => 'bwlzss',\n\n    CHUNK_SIZE    => 1 << 17,    # higher value = better compression\n    LOOKAHEAD_LEN => 128,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\n# [distance value, offset bits]\nmy @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4);\n\nuntil ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) {\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n}\n\n# [length, offset bits]\nmy @LENGTH_SYMBOLS = ((map { [$_, 0] } (3 .. 10)));\n\n{\n    my $delta = 1;\n    until ($LENGTH_SYMBOLS[-1][0] > 163) {\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1];\n        $delta *= 2;\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n    }\n    push @LENGTH_SYMBOLS, [258, 0];\n}\n\nmy @DISTANCE_INDICES;\n\nforeach my $i (0 .. $#DISTANCE_SYMBOLS) {\n    my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        last if ($k > CHUNK_SIZE);\n        $DISTANCE_INDICES[$k] = $i;\n    }\n}\n\nmy @LENGTH_INDICES;\n\nforeach my $i (0 .. $#LENGTH_SYMBOLS) {\n    my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        $LENGTH_INDICES[$k] = $i;\n    }\n}\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    my $min_len = $LENGTH_SYMBOLS[0][0];\n    my $max_len = $LENGTH_SYMBOLS[-1][0];\n\n    my %literal_freq;\n    my %distance_freq;\n\n    my $literal_count  = 0;\n    my $distance_count = 0;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n <= $max_len\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        my $enc_bits_len     = 0;\n        my $literal_bits_len = 0;\n\n        if ($n > $min_len) {\n\n            my $dist = $DISTANCE_SYMBOLS[$DISTANCE_INDICES[$la - $p]];\n            $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0))));\n\n            my $len_idx = $LENGTH_INDICES[$n - 1];\n            my $len     = $LENGTH_SYMBOLS[$len_idx];\n\n            $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0))));\n\n            my %freq;\n            foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) {\n                ++$freq{$c};\n                $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0))));\n            }\n        }\n\n        if ($n > $min_len and $enc_bits_len < $literal_bits_len) {\n\n            push @$lengths,      $n - 1;\n            push @$indices,      $la - $p;\n            push @$uncompressed, undef;\n\n            my $dist_idx = $DISTANCE_INDICES[$la - $p];\n            my $dist     = $DISTANCE_SYMBOLS[$dist_idx];\n\n            ++$distance_count;\n            ++$distance_freq{$dist->[0]};\n\n            ++$literal_count;\n            ++$literal_freq{$LENGTH_INDICES[$n - 1] + 256};\n\n            $la += $n - 1;\n            $prefix .= substr($token, 0, -1);\n        }\n        else {\n            my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]);\n\n            push @$uncompressed, @bytes;\n            push @$lengths, (0) x scalar(@bytes);\n            push @$indices, (0) x scalar(@bytes);\n\n            ++$literal_freq{$_} for @bytes;\n\n            $literal_count += $n;\n            $la            += $n;\n            $prefix .= $token;\n        }\n    }\n\n    return;\n}\n\nsub lz77_decompression ($literals, $distances, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#$literals) {\n        if ($lengths->[$i] != 0) {\n            $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]);\n            $offset += $lengths->[$i];\n        }\n        else {\n            $chunk .= chr($literals->[$i]);\n            $offset += 1;\n        }\n    }\n\n    return $chunk;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n    say \"Max symbol: $max_symbol\";\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\nsub deflate_encode ($literals, $distances, $lengths, $out_fh) {\n\n    my @len_symbols;\n    my @dist_symbols;\n    my $offset_bits = '';\n\n    foreach my $j (0 .. $#{$literals}) {\n\n        if ($lengths->[$j] == 0) {\n            push @len_symbols, $literals->[$j];\n            next;\n        }\n\n        my $len  = $lengths->[$j];\n        my $dist = $distances->[$j];\n\n        {\n            my $len_idx = $LENGTH_INDICES[$len];\n            my ($min, $bits) = @{$LENGTH_SYMBOLS[$len_idx]};\n\n            push @len_symbols, $len_idx + 256;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $len - $min);\n            }\n        }\n\n        {\n            my $dist_idx = $DISTANCE_INDICES[$dist];\n            my ($min, $bits) = @{$DISTANCE_SYMBOLS[$dist_idx]};\n\n            push @dist_symbols, $dist_idx;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $dist - $min);\n            }\n        }\n    }\n\n    create_huffman_entry(\\@len_symbols,  $out_fh);\n    create_huffman_entry(\\@dist_symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n}\n\nsub deflate_decode ($fh) {\n\n    my $len_symbols  = decode_huffman_entry($fh);\n    my $dist_symbols = decode_huffman_entry($fh);\n\n    my $bits_len = 0;\n\n    foreach my $i (@$dist_symbols) {\n        $bits_len += $DISTANCE_SYMBOLS[$i][1];\n    }\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            $bits_len += $LENGTH_SYMBOLS[$i - 256][1];\n        }\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @literals;\n    my @lengths;\n    my @distances;\n\n    my $j = 0;\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            my $dist = $dist_symbols->[$j++];\n            push @literals,  undef;\n            push @lengths,   $LENGTH_SYMBOLS[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS[$i - 256][1], ''));\n            push @distances, $DISTANCE_SYMBOLS[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$dist][1], ''));\n        }\n        else {\n            push @literals,  $i;\n            push @lengths,   0;\n            push @distances, 0;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 254 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub lzss_compression ($data, $out_fh) {\n    my (@uncompressed, @indices, @lengths);\n    lz77_compression($data, \\@uncompressed, \\@indices, \\@lengths);\n\n    my $est_ratio = length($data) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices));\n    say \"\\nEst. ratio: \", $est_ratio, \" (\", scalar(@uncompressed), \" uncompressed bytes)\";\n\n    deflate_encode(\\@uncompressed, \\@indices, \\@lengths, $out_fh);\n}\n\nsub lzss_decompression ($fh) {\n    my ($uncompressed, $indices, $lengths) = deflate_decode($fh);\n    lz77_decompression($uncompressed, $indices, $lengths);\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my $rle4 = rle4_encode([unpack('C*', $chunk)]);\n    my ($bwt, $idx) = bwt_encode(pack('C*', @$rle4));\n\n    print $out_fh pack('N', $idx);\n    lzss_compression($bwt, $out_fh);\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $idx = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n\n    my $bwt  = lzss_decompression($fh);\n    my $rle4 = bwt_decode($bwt, $idx);\n    my $data = rle4_decode([unpack('C*', $rle4)]);\n\n    print $out_fh pack('C*', @$data);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/bwrl2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 10 September 2023\n# Edit: 29 February 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Variable Run-Length encoding + Bzip2.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\n\nuse constant {\n    PKGNAME => 'BWRL2',\n    VERSION => '0.01',\n    FORMAT  => 'bwrl2',\n\n    CHUNK_SIZE    => 1 << 17,    # higher value = better compression\n    LOOKAHEAD_LEN => 128,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n    say \"Max symbol: $max_symbol\\n\";\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    say \"Encoded length: $enc_len\\n\";\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 254 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        if ($enc == 0) {\n            $populated <<= 1;\n        }\n        else {\n            ($populated <<= 1) |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta);\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh))));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\nsub bz2_compression ($chunk, $out_fh, $with_bwt = 0) {\n\n    my @bytes = $with_bwt\n      ? do {\n        my ($bwt, $idx) = bwt_encode(pack('C*', @$chunk));\n        say \"BWT index = $idx\";\n        print $out_fh pack('N', $idx);\n        unpack('C*', $bwt);\n      }\n      : @$chunk;\n\n    my @alphabet     = sort { $a <=> $b } uniq(@bytes);\n    my $alphabet_enc = encode_alphabet(\\@alphabet);\n\n    my $mtf  = mtf_encode(\\@bytes, [@alphabet]);\n    my $rle4 = rle4_encode($mtf);\n    my $rle  = rle_encode($rle4);\n\n    print $out_fh $alphabet_enc;\n    create_huffman_entry($rle, $out_fh);\n}\n\nsub bz2_decompression ($fh, $out_fh, $with_bwt = 0) {\n\n    my $idx      = $with_bwt ? unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)) : 0;\n    my $alphabet = decode_alphabet($fh);\n\n    say \"BWT index = $idx\" if $with_bwt;\n    say \"Alphabet size: \", scalar(@$alphabet);\n\n    my $rle   = decode_huffman_entry($fh);\n    my $rle4  = rle_decode($rle);\n    my $mtf   = rle4_decode($rle4);\n    my $bwt   = mtf_decode($mtf, $alphabet);\n    my @bytes = $with_bwt ? unpack('C*', bwt_decode(pack('C*', @$bwt), $idx)) : @$bwt;\n    print $out_fh pack('C*', @bytes);\n}\n\nsub run_length ($arr) {\n\n    @$arr || return [];\n\n    my @result     = [$arr->[0], 1];\n    my $prev_value = $arr->[0];\n\n    foreach my $i (1 .. $#{$arr}) {\n\n        my $curr_value = $arr->[$i];\n\n        if ($curr_value eq $prev_value) {\n            ++$result[-1][1];\n        }\n        else {\n            push(@result, [$curr_value, 1]);\n        }\n\n        $prev_value = $curr_value;\n    }\n\n    return \\@result;\n}\n\nsub VLR_encoding ($bytes) {\n\n    my $uncompressed = '';\n    my $bitstream    = '';\n    my $rle          = run_length($bytes);\n\n    foreach my $cv (@$rle) {\n        my ($c, $v) = @$cv;\n        $uncompressed .= $c;\n        if ($v == 1) {\n            $bitstream .= '0';\n        }\n        else {\n            my $t = sprintf('%b', $v);\n            $bitstream .= join('', '1' x (length($t) - 1), '0', substr($t, 1));\n        }\n    }\n\n    return ($uncompressed, pack('B*', $bitstream));\n}\n\nsub VLR_decoding ($uncompressed, $bits_fh) {\n\n    my $decoded = '';\n    my $buffer  = '';\n\n    foreach my $c (@$uncompressed) {\n\n        my $bl = 0;\n        while (read_bit($bits_fh, \\$buffer) == 1) {\n            ++$bl;\n        }\n\n        if ($bl > 0) {\n            $decoded .= $c x oct('0b1' . join('', map { read_bit($bits_fh, \\$buffer) } 1 .. $bl));\n        }\n        else {\n            $decoded .= $c;\n        }\n    }\n\n    return $decoded;\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my ($bwt,          $idx)     = bwt_encode(pack('C*', @{rle4_encode([unpack('C*', $chunk)])}));\n        my ($uncompressed, $lengths) = VLR_encoding([split(//, $bwt)]);\n\n        print $out_fh pack('N', $idx);\n        bz2_compression([unpack('C*', $uncompressed)], $out_fh);\n        bz2_compression([unpack('C*', $lengths)], $out_fh, 1);\n    }\n\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my $uncompressed = '';\n        my $lengths      = '';\n\n        open my $uc_fh,  '>:raw',  \\$uncompressed;\n        open my $len_fh, '+>:raw', \\$lengths;\n\n        my $idx = unpack('N', join('', map { getc($fh) // die \"decompression error\" } 1 .. 4));\n\n        bz2_decompression($fh, $uc_fh);        # uncompressed\n        bz2_decompression($fh, $len_fh, 1);    # lengths\n\n        seek($len_fh, 0, 0);\n\n        my $dec = VLR_decoding([split(//, $uncompressed)], $len_fh);\n        print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode($dec, $idx))])});\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/bwrl_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 10 September 2023\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Variable Run-Length encoding + Bzip2.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\n\nuse constant {\n    PKGNAME => 'BWRL',\n    VERSION => '0.01',\n    FORMAT  => 'bwrl',\n\n    CHUNK_SIZE    => 1 << 17,    # higher value = better compression\n    LOOKAHEAD_LEN => 128,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n    say \"Max symbol: $max_symbol\\n\";\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    say \"Encoded length: $enc_len\\n\";\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        if ($enc == 0) {\n            $populated <<= 1;\n        }\n        else {\n            ($populated <<= 1) |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta);\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh))));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\nsub bz2_compression ($chunk, $out_fh) {\n\n    my $rle1 = rle4_encode([unpack('C*', $chunk)]);\n    my ($bwt, $idx) = bwt_encode(pack('C*', @$rle1));\n\n    say \"BWT index = $idx\";\n\n    my @bytes        = unpack('C*', $bwt);\n    my @alphabet     = sort { $a <=> $b } uniq(@bytes);\n    my $alphabet_enc = encode_alphabet(\\@alphabet);\n\n    my $mtf = mtf_encode(\\@bytes, [@alphabet]);\n    my $rle = rle_encode($mtf);\n\n    print $out_fh pack('N', $idx);\n    print $out_fh $alphabet_enc;\n    create_huffman_entry($rle, $out_fh);\n}\n\nsub bz2_decompression ($fh, $out_fh) {\n\n    my $idx      = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4));\n    my $alphabet = decode_alphabet($fh);\n\n    say \"BWT index = $idx\";\n    say \"Alphabet size: \", scalar(@$alphabet);\n\n    my $rle  = decode_huffman_entry($fh);\n    my $mtf  = rle_decode($rle);\n    my $bwt  = mtf_decode($mtf, $alphabet);\n    my $rle4 = bwt_decode(pack('C*', @$bwt), $idx);\n    my $data = rle4_decode([unpack('C*', $rle4)]);\n\n    print $out_fh pack('C*', @$data);\n}\n\nsub run_length ($arr) {\n\n    @$arr || return [];\n\n    my @result     = [$arr->[0], 1];\n    my $prev_value = $arr->[0];\n\n    foreach my $i (1 .. $#{$arr}) {\n\n        my $curr_value = $arr->[$i];\n\n        if ($curr_value eq $prev_value) {\n            ++$result[-1][1];\n        }\n        else {\n            push(@result, [$curr_value, 1]);\n        }\n\n        $prev_value = $curr_value;\n    }\n\n    return \\@result;\n}\n\nsub VLR_encoding ($bytes) {\n\n    my $uncompressed = '';\n    my $bitstream    = '';\n    my $rle          = run_length($bytes);\n\n    foreach my $cv (@$rle) {\n        my ($c, $v) = @$cv;\n        $uncompressed .= $c;\n        if ($v == 1) {\n            $bitstream .= '0';\n        }\n        else {\n            my $t = sprintf('%b', $v);\n            $bitstream .= join('', '1' x (length($t) - 1), '0', substr($t, 1));\n        }\n    }\n\n    return ($uncompressed, pack('B*', $bitstream));\n}\n\nsub VLR_decoding ($uncompressed, $bits_fh) {\n\n    my $decoded = '';\n    my $buffer  = '';\n\n    foreach my $c (@$uncompressed) {\n\n        my $bl = 0;\n        while (read_bit($bits_fh, \\$buffer) == 1) {\n            ++$bl;\n        }\n\n        if ($bl > 0) {\n            $decoded .= $c x oct('0b1' . join('', map { read_bit($bits_fh, \\$buffer) } 1 .. $bl));\n        }\n        else {\n            $decoded .= $c;\n        }\n    }\n\n    return $decoded;\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my ($bwt,          $idx)     = bwt_encode(pack('C*', @{rle4_encode([unpack('C*', $chunk)])}));\n        my ($uncompressed, $lengths) = VLR_encoding([split(//, $bwt)]);\n\n        print $out_fh pack('N', $idx);\n        bz2_compression($uncompressed, $out_fh);\n        bz2_compression($lengths,      $out_fh);\n    }\n\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my $uncompressed = '';\n        my $lengths      = '';\n\n        open my $uc_fh,  '>:raw',  \\$uncompressed;\n        open my $len_fh, '+>:raw', \\$lengths;\n\n        my $idx = unpack('N', join('', map { getc($fh) // die \"decompression error\" } 1 .. 4));\n\n        bz2_decompression($fh, $uc_fh);     # uncompressed\n        bz2_decompression($fh, $len_fh);    # lengths\n\n        seek($len_fh, 0, 0);\n\n        my $dec = VLR_decoding([split(//, $uncompressed)], $len_fh);\n        print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode($dec, $idx))])});\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/bwrla_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 10 September 2023\n# Edit: 23 February 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Variable Run-Length encoding + Bzip2 (with Arithmetic Coding).\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n#\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\n\nuse constant {\n    PKGNAME => 'BWRLA',\n    VERSION => '0.01',\n    FORMAT  => 'bwrla',\n\n    CHUNK_SIZE    => 1 << 17,    # higher value = better compression\n    LOOKAHEAD_LEN => 128,\n};\n\n# Arithmetic Coding settings\nuse constant BITS => 32;\nuse constant MAX  => oct('0b' . ('1' x BITS));\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub create_cfreq ($freq) {\n\n    my @cf;\n    my $T = 0;\n\n    foreach my $i (sort { $a <=> $b } keys %$freq) {\n        $freq->{$i} // next;\n        $cf[$i] = $T;\n        $T += $freq->{$i};\n        $cf[$i + 1] = $T;\n    }\n\n    return (\\@cf, $T);\n}\n\nsub ac_encode ($bytes_arr) {\n\n    my $enc        = '';\n    my $EOF_SYMBOL = (max(@$bytes_arr) // 0) + 1;\n    my @bytes      = (@$bytes_arr, $EOF_SYMBOL);\n\n    my %freq;\n    ++$freq{$_} for @bytes;\n\n    my ($cf, $T) = create_cfreq(\\%freq);\n\n    if ($T > MAX) {\n        die \"Too few bits: $T > ${\\MAX}\";\n    }\n\n    my $low      = 0;\n    my $high     = MAX;\n    my $uf_count = 0;\n\n    foreach my $c (@bytes) {\n\n        my $w = $high - $low + 1;\n\n        $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$c]) / $T)) & MAX;\n\n        if ($high > MAX) {\n            die \"high > MAX: $high > ${\\MAX}\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n\n                my $bit = $high >> (BITS - 1);\n                $enc .= $bit;\n\n                if ($uf_count > 0) {\n                    $enc .= join('', 1 - $bit) x $uf_count;\n                    $uf_count = 0;\n                }\n\n                $low <<= 1;\n                ($high <<= 1) |= 1;\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                ++$uf_count;\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n        }\n    }\n\n    $enc .= '0';\n    $enc .= '1';\n\n    while (length($enc) % 8 != 0) {\n        $enc .= '1';\n    }\n\n    return ($enc, \\%freq);\n}\n\nsub ac_decode ($fh, $freq) {\n\n    my ($cf, $T) = create_cfreq($freq);\n\n    my @dec;\n    my $low  = 0;\n    my $high = MAX;\n    my $enc  = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS);\n\n    my @table;\n    foreach my $i (sort { $a <=> $b } keys %$freq) {\n        foreach my $j ($cf->[$i] .. $cf->[$i + 1] - 1) {\n            $table[$j] = $i;\n        }\n    }\n\n    my $EOF_SYMBOL = max(keys %$freq) // 0;\n\n    while (1) {\n\n        my $w  = $high - $low + 1;\n        my $ss = int((($T * ($enc - $low + 1)) - 1) / $w);\n\n        my $i = $table[$ss] // last;\n        last if ($i == $EOF_SYMBOL);\n\n        push @dec, $i;\n\n        $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$i]) / $T)) & MAX;\n\n        if ($high > MAX) {\n            die \"error\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n                ($high <<= 1) |= 1;\n                $low <<= 1;\n                ($enc <<= 1) |= (getc($fh) // 1);\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1);\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n            $enc  &= MAX;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub create_ac_entry ($bytes, $out_fh) {\n\n    my ($enc, $freq) = ac_encode($bytes);\n    my $max_symbol = max(keys %$freq) // 0;\n\n    my @freqs;\n    foreach my $k (0 .. $max_symbol) {\n        push @freqs, $freq->{$k} // 0;\n    }\n\n    push @freqs, length($enc) >> 3;\n\n    say \"Max symbol: $max_symbol\\n\";\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_ac_entry ($fh) {\n\n    my @freqs    = @{delta_decode($fh)};\n    my $bits_len = pop(@freqs);\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    say \"Encoded length: $bits_len\\n\";\n    my $bits = read_bits($fh, $bits_len << 3);\n\n    if ($bits_len > 0) {\n        open my $bits_fh, '<:raw', \\$bits;\n        return ac_decode($bits_fh, \\%freq);\n    }\n\n    return [];\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        if ($enc == 0) {\n            $populated <<= 1;\n        }\n        else {\n            ($populated <<= 1) |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta);\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh))));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\nsub bz2_compression ($chunk, $out_fh) {\n\n    my $rle1 = rle4_encode([unpack('C*', $chunk)]);\n    my ($bwt, $idx) = bwt_encode(pack('C*', @$rle1));\n\n    say \"BWT index = $idx\";\n\n    my @bytes        = unpack('C*', $bwt);\n    my @alphabet     = sort { $a <=> $b } uniq(@bytes);\n    my $alphabet_enc = encode_alphabet(\\@alphabet);\n\n    my $mtf = mtf_encode(\\@bytes, [@alphabet]);\n    my $rle = rle_encode($mtf);\n\n    print $out_fh pack('N', $idx);\n    print $out_fh $alphabet_enc;\n    create_ac_entry($rle, $out_fh);\n}\n\nsub bz2_decompression ($fh, $out_fh) {\n\n    my $idx      = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4));\n    my $alphabet = decode_alphabet($fh);\n\n    say \"BWT index = $idx\";\n    say \"Alphabet size: \", scalar(@$alphabet);\n\n    my $rle  = decode_ac_entry($fh);\n    my $mtf  = rle_decode($rle);\n    my $bwt  = mtf_decode($mtf, $alphabet);\n    my $rle4 = bwt_decode(pack('C*', @$bwt), $idx);\n    my $data = rle4_decode([unpack('C*', $rle4)]);\n\n    print $out_fh pack('C*', @$data);\n}\n\nsub run_length ($arr) {\n\n    @$arr || return [];\n\n    my @result     = [$arr->[0], 1];\n    my $prev_value = $arr->[0];\n\n    foreach my $i (1 .. $#{$arr}) {\n\n        my $curr_value = $arr->[$i];\n\n        if ($curr_value eq $prev_value) {\n            ++$result[-1][1];\n        }\n        else {\n            push(@result, [$curr_value, 1]);\n        }\n\n        $prev_value = $curr_value;\n    }\n\n    return \\@result;\n}\n\nsub VLR_encoding ($bytes) {\n\n    my $uncompressed = '';\n    my $bitstream    = '';\n    my $rle          = run_length($bytes);\n\n    foreach my $cv (@$rle) {\n        my ($c, $v) = @$cv;\n        $uncompressed .= $c;\n        if ($v == 1) {\n            $bitstream .= '0';\n        }\n        else {\n            my $t = sprintf('%b', $v);\n            $bitstream .= join('', '1' x (length($t) - 1), '0', substr($t, 1));\n        }\n    }\n\n    return ($uncompressed, pack('B*', $bitstream));\n}\n\nsub VLR_decoding ($uncompressed, $bits_fh) {\n\n    my $decoded = '';\n    my $buffer  = '';\n\n    foreach my $c (@$uncompressed) {\n\n        my $bl = 0;\n        while (read_bit($bits_fh, \\$buffer) == 1) {\n            ++$bl;\n        }\n\n        if ($bl > 0) {\n            $decoded .= $c x oct('0b1' . join('', map { read_bit($bits_fh, \\$buffer) } 1 .. $bl));\n        }\n        else {\n            $decoded .= $c;\n        }\n    }\n\n    return $decoded;\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my ($bwt,          $idx)     = bwt_encode(pack('C*', @{rle4_encode([unpack('C*', $chunk)])}));\n        my ($uncompressed, $lengths) = VLR_encoding([split(//, $bwt)]);\n\n        print $out_fh pack('N', $idx);\n        bz2_compression($uncompressed, $out_fh);\n        bz2_compression($lengths,      $out_fh);\n    }\n\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my $uncompressed = '';\n        my $lengths      = '';\n\n        open my $uc_fh,  '>:raw',  \\$uncompressed;\n        open my $len_fh, '+>:raw', \\$lengths;\n\n        my $idx = unpack('N', join('', map { getc($fh) // die \"decompression error\" } 1 .. 4));\n\n        bz2_decompression($fh, $uc_fh);     # uncompressed\n        bz2_decompression($fh, $len_fh);    # lengths\n\n        seek($len_fh, 0, 0);\n\n        my $dec = VLR_decoding([split(//, $uncompressed)], $len_fh);\n        print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode($dec, $idx))])});\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/bwrlz2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 10 September 2023\n# Edit: 19 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Variable Run-Length encoding + LZSS + Bzip2.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\nuse POSIX          qw(ceil log2);\n\nuse constant {\n    PKGNAME => 'BWRLZ2',\n    VERSION => '0.01',\n    FORMAT  => 'bwrlz2',\n\n    CHUNK_SIZE    => 1 << 17,    # higher value = better compression\n    LOOKAHEAD_LEN => 128,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\n# [distance value, offset bits]\nmy @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4);\n\nuntil ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) {\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n}\n\n# [length, offset bits]\nmy @LENGTH_SYMBOLS = ((map { [$_, 0] } (3 .. 10)));\n\n{\n    my $delta = 1;\n    until ($LENGTH_SYMBOLS[-1][0] > 163) {\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1];\n        $delta *= 2;\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n    }\n    push @LENGTH_SYMBOLS, [258, 0];\n}\n\nmy @DISTANCE_INDICES;\n\nforeach my $i (0 .. $#DISTANCE_SYMBOLS) {\n    my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        last if ($k > CHUNK_SIZE);\n        $DISTANCE_INDICES[$k] = $i;\n    }\n}\n\nmy @LENGTH_INDICES;\n\nforeach my $i (0 .. $#LENGTH_SYMBOLS) {\n    my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        $LENGTH_INDICES[$k] = $i;\n    }\n}\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    my $min_len = $LENGTH_SYMBOLS[0][0];\n    my $max_len = $LENGTH_SYMBOLS[-1][0];\n\n    my %literal_freq;\n    my %distance_freq;\n\n    my $literal_count  = 0;\n    my $distance_count = 0;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n <= $max_len\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        my $enc_bits_len     = 0;\n        my $literal_bits_len = 0;\n\n        if ($n > $min_len) {\n\n            my $dist = $DISTANCE_SYMBOLS[$DISTANCE_INDICES[$la - $p]];\n            $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0))));\n\n            my $len_idx = $LENGTH_INDICES[$n - 1];\n            my $len     = $LENGTH_SYMBOLS[$len_idx];\n\n            $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0))));\n\n            my %freq;\n            foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) {\n                ++$freq{$c};\n                $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0))));\n            }\n        }\n\n        if ($n > $min_len and $enc_bits_len < $literal_bits_len) {\n\n            push @$lengths,      $n - 1;\n            push @$indices,      $la - $p;\n            push @$uncompressed, undef;\n\n            my $dist_idx = $DISTANCE_INDICES[$la - $p];\n            my $dist     = $DISTANCE_SYMBOLS[$dist_idx];\n\n            ++$distance_count;\n            ++$distance_freq{$dist->[0]};\n\n            ++$literal_count;\n            ++$literal_freq{$LENGTH_INDICES[$n - 1] + 256};\n\n            $la += $n - 1;\n            $prefix .= substr($token, 0, -1);\n        }\n        else {\n            my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]);\n\n            push @$uncompressed, @bytes;\n            push @$lengths, (0) x scalar(@bytes);\n            push @$indices, (0) x scalar(@bytes);\n\n            ++$literal_freq{$_} for @bytes;\n\n            $literal_count += $n;\n            $la            += $n;\n            $prefix .= $token;\n        }\n    }\n\n    return;\n}\n\nsub lz77_decompression ($literals, $distances, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#$literals) {\n        if ($lengths->[$i] != 0) {\n            $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]);\n            $offset += $lengths->[$i];\n        }\n        else {\n            $chunk .= chr($literals->[$i]);\n            $offset += 1;\n        }\n    }\n\n    return $chunk;\n}\n\nsub deflate_encode ($literals, $distances, $lengths, $out_fh) {\n\n    my @len_symbols;\n    my @dist_symbols;\n    my $offset_bits = '';\n\n    foreach my $j (0 .. $#{$literals}) {\n\n        if ($lengths->[$j] == 0) {\n            push @len_symbols, $literals->[$j];\n            next;\n        }\n\n        my $len  = $lengths->[$j];\n        my $dist = $distances->[$j];\n\n        {\n            my $len_idx = $LENGTH_INDICES[$len];\n            my ($min, $bits) = @{$LENGTH_SYMBOLS[$len_idx]};\n\n            push @len_symbols, $len_idx + 256;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $len - $min);\n            }\n        }\n\n        {\n            my $dist_idx = $DISTANCE_INDICES[$dist];\n            my ($min, $bits) = @{$DISTANCE_SYMBOLS[$dist_idx]};\n\n            push @dist_symbols, $dist_idx;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $dist - $min);\n            }\n        }\n    }\n\n    bz2_compression_symbolic(\\@len_symbols,  $out_fh);\n    bz2_compression_symbolic(\\@dist_symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n}\n\nsub deflate_decode ($fh) {\n\n    my $len_symbols  = bz2_decompression_symbolic($fh);\n    my $dist_symbols = bz2_decompression_symbolic($fh);\n\n    my $bits_len = 0;\n\n    foreach my $i (@$dist_symbols) {\n        $bits_len += $DISTANCE_SYMBOLS[$i][1];\n    }\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            $bits_len += $LENGTH_SYMBOLS[$i - 256][1];\n        }\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @literals;\n    my @lengths;\n    my @distances;\n\n    my $j = 0;\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            my $dist = $dist_symbols->[$j++];\n            push @literals,  undef;\n            push @lengths,   $LENGTH_SYMBOLS[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS[$i - 256][1], ''));\n            push @distances, $DISTANCE_SYMBOLS[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$dist][1], ''));\n        }\n        else {\n            push @literals,  $i;\n            push @lengths,   0;\n            push @distances, 0;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub bwt_sort_symbolic ($s) {    # O(n) space (slowish)\n\n    my @cyclic = @$s;\n    my $len    = scalar(@cyclic);\n\n    my $rle = 1;\n    foreach my $i (1 .. $len - 1) {\n        if ($cyclic[$i] != $cyclic[$i - 1]) {\n            $rle = 0;\n            last;\n        }\n    }\n\n    $rle && return [0 .. $len - 1];\n\n    [\n     sort {\n         my ($i, $j) = ($a, $b);\n\n         while ($cyclic[$i] == $cyclic[$j]) {\n             $i %= $len if (++$i >= $len);\n             $j %= $len if (++$j >= $len);\n         }\n\n         $cyclic[$i] <=> $cyclic[$j];\n       } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode_symbolic ($s) {\n\n    my $bwt = bwt_sort_symbolic($s);\n    my @ret = map { $s->[$_ - 1] } @$bwt;\n\n    my $idx = 0;\n    foreach my $i (@$bwt) {\n        $i || last;\n        ++$idx;\n    }\n\n    return (\\@ret, $idx);\n}\n\nsub bwt_decode_symbolic ($bwt, $idx) {    # fast inversion\n\n    my @tail = @$bwt;\n    my @head = sort { $a <=> $b } @tail;\n\n    my @indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices[$tail[$i]]}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices[$v]});\n    }\n\n    my @dec;\n    my $i = $idx;\n\n    for (1 .. scalar(@head)) {\n        push @dec, $head[$i];\n        $i = $table[$i];\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet_symbolic ($alphabet) {\n    return delta_encode([@$alphabet]);\n}\n\nsub decode_alphabet_symbolic ($fh) {\n    return delta_decode($fh);\n}\n\nsub bz2_compression_symbolic ($symbols, $out_fh) {\n\n    my ($bwt, $idx) = bwt_encode_symbolic($symbols);\n\n    my @bytes        = @$bwt;\n    my @alphabet     = sort { $a <=> $b } uniq(@bytes);\n    my $alphabet_enc = encode_alphabet_symbolic(\\@alphabet);\n\n    say \"BWT index = $idx\";\n    say \"Max symbol: \", max(@alphabet) // 0;\n\n    my $mtf = mtf_encode(\\@bytes, [@alphabet]);\n    my $rle = rle_encode($mtf);\n\n    print $out_fh pack('N', $idx);\n    print $out_fh $alphabet_enc;\n    create_huffman_entry($rle, $out_fh);\n}\n\nsub bz2_decompression_symbolic ($fh) {\n\n    my $idx      = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    my $alphabet = decode_alphabet_symbolic($fh);\n\n    say \"BWT index = $idx\";\n    say \"Alphabet size: \", scalar(@$alphabet);\n\n    my $rle  = decode_huffman_entry($fh);\n    my $mtf  = rle_decode($rle);\n    my $bwt  = mtf_decode($mtf, $alphabet);\n    my $data = bwt_decode_symbolic($bwt, $idx);\n\n    return $data;\n}\n\nsub lzss_compression ($chunk, $out_fh) {\n    my (@uncompressed, @indices, @lengths);\n    lz77_compression($chunk, \\@uncompressed, \\@indices, \\@lengths);\n\n    my $est_ratio = length($chunk) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices));\n    say scalar(@uncompressed), ' -> ', $est_ratio;\n\n    deflate_encode(\\@uncompressed, \\@indices, \\@lengths, $out_fh);\n}\n\nsub lzss_decompression ($fh, $out_fh) {\n    my ($uncompressed, $indices, $lengths) = deflate_decode($fh);\n    print $out_fh lz77_decompression($uncompressed, $indices, $lengths);\n}\n\nsub run_length ($arr) {\n\n    @$arr || return [];\n\n    my @result     = [$arr->[0], 1];\n    my $prev_value = $arr->[0];\n\n    foreach my $i (1 .. $#{$arr}) {\n\n        my $curr_value = $arr->[$i];\n\n        if ($curr_value eq $prev_value) {\n            ++$result[-1][1];\n        }\n        else {\n            push(@result, [$curr_value, 1]);\n        }\n\n        $prev_value = $curr_value;\n    }\n\n    return \\@result;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub VLR_encoding ($bytes) {\n\n    my $uncompressed = '';\n    my $bitstream    = '';\n    my $rle          = run_length($bytes);\n\n    foreach my $cv (@$rle) {\n        my ($c, $v) = @$cv;\n        $uncompressed .= $c;\n        if ($v == 1) {\n            $bitstream .= '0';\n        }\n        else {\n            my $t = sprintf('%b', $v);\n            $bitstream .= join('', '1' x (length($t) - 1), '0', substr($t, 1));\n        }\n    }\n\n    return ($uncompressed, pack('B*', $bitstream));\n}\n\nsub VLR_decoding ($uncompressed, $bits_fh) {\n\n    my $decoded = '';\n    my $buffer  = '';\n\n    foreach my $c (@$uncompressed) {\n\n        my $bl = 0;\n        while (read_bit($bits_fh, \\$buffer) == 1) {\n            ++$bl;\n        }\n\n        if ($bl > 0) {\n            $decoded .= $c x oct('0b1' . join('', map { read_bit($bits_fh, \\$buffer) } 1 .. $bl));\n        }\n        else {\n            $decoded .= $c;\n        }\n    }\n\n    return $decoded;\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my ($bwt,          $idx)     = bwt_encode(pack('C*', @{rle4_encode([unpack('C*', $chunk)])}));\n        my ($uncompressed, $lengths) = VLR_encoding([split(//, $bwt)]);\n\n        print $out_fh pack('N', $idx);\n\n        lzss_compression($uncompressed, $out_fh);\n        lzss_compression($lengths,      $out_fh);\n    }\n\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my $uncompressed = '';\n        my $lengths      = '';\n\n        open my $uc_fh,  '>:raw',  \\$uncompressed;\n        open my $len_fh, '+>:raw', \\$lengths;\n\n        my $idx = unpack('N', join('', map { getc($fh) // die \"decompression error\" } 1 .. 4));\n\n        lzss_decompression($fh, $uc_fh);     # uncompressed\n        lzss_decompression($fh, $len_fh);    # lengths\n\n        seek($len_fh, 0, 0);\n\n        my $dec = VLR_decoding([split(//, $uncompressed)], $len_fh);\n        print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode($dec, $idx))])});\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/bwrlz_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 10 September 2023\n# Edit: 29 February 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Variable Run-Length encoding + LZSS.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\nuse POSIX          qw(ceil log2);\n\nuse constant {\n    PKGNAME => 'BWRLZ',\n    VERSION => '0.01',\n    FORMAT  => 'bwrlz',\n\n    CHUNK_SIZE    => 1 << 17,    # higher value = better compression\n    LOOKAHEAD_LEN => 128,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\n# [distance value, offset bits]\nmy @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4);\n\nuntil ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) {\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n}\n\n# [length, offset bits]\nmy @LENGTH_SYMBOLS = ((map { [$_, 0] } (3 .. 10)));\n\n{\n    my $delta = 1;\n    until ($LENGTH_SYMBOLS[-1][0] > 163) {\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1];\n        $delta *= 2;\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n    }\n    push @LENGTH_SYMBOLS, [258, 0];\n}\n\nmy @DISTANCE_INDICES;\n\nforeach my $i (0 .. $#DISTANCE_SYMBOLS) {\n    my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        last if ($k > CHUNK_SIZE);\n        $DISTANCE_INDICES[$k] = $i;\n    }\n}\n\nmy @LENGTH_INDICES;\n\nforeach my $i (0 .. $#LENGTH_SYMBOLS) {\n    my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        $LENGTH_INDICES[$k] = $i;\n    }\n}\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    my $min_len = $LENGTH_SYMBOLS[0][0];\n    my $max_len = $LENGTH_SYMBOLS[-1][0];\n\n    my %literal_freq;\n    my %distance_freq;\n\n    my $literal_count  = 0;\n    my $distance_count = 0;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n <= $max_len\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        my $enc_bits_len     = 0;\n        my $literal_bits_len = 0;\n\n        if ($n > $min_len) {\n\n            my $dist = $DISTANCE_SYMBOLS[$DISTANCE_INDICES[$la - $p]];\n            $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0))));\n\n            my $len_idx = $LENGTH_INDICES[$n - 1];\n            my $len     = $LENGTH_SYMBOLS[$len_idx];\n\n            $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0))));\n\n            my %freq;\n            foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) {\n                ++$freq{$c};\n                $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0))));\n            }\n        }\n\n        if ($n > $min_len and $enc_bits_len < $literal_bits_len) {\n\n            push @$lengths,      $n - 1;\n            push @$indices,      $la - $p;\n            push @$uncompressed, undef;\n\n            my $dist_idx = $DISTANCE_INDICES[$la - $p];\n            my $dist     = $DISTANCE_SYMBOLS[$dist_idx];\n\n            ++$distance_count;\n            ++$distance_freq{$dist->[0]};\n\n            ++$literal_count;\n            ++$literal_freq{$LENGTH_INDICES[$n - 1] + 256};\n\n            $la += $n - 1;\n            $prefix .= substr($token, 0, -1);\n        }\n        else {\n            my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]);\n\n            push @$uncompressed, @bytes;\n            push @$lengths, (0) x scalar(@bytes);\n            push @$indices, (0) x scalar(@bytes);\n\n            ++$literal_freq{$_} for @bytes;\n\n            $literal_count += $n;\n            $la            += $n;\n            $prefix .= $token;\n        }\n    }\n\n    return;\n}\n\nsub lz77_decompression ($literals, $distances, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#$literals) {\n        if ($lengths->[$i] != 0) {\n            $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]);\n            $offset += $lengths->[$i];\n        }\n        else {\n            $chunk .= chr($literals->[$i]);\n            $offset += 1;\n        }\n    }\n\n    return $chunk;\n}\n\nsub deflate_encode ($literals, $distances, $lengths, $out_fh) {\n\n    my @len_symbols;\n    my @dist_symbols;\n    my $offset_bits = '';\n\n    foreach my $j (0 .. $#{$literals}) {\n\n        if ($lengths->[$j] == 0) {\n            push @len_symbols, $literals->[$j];\n            next;\n        }\n\n        my $len  = $lengths->[$j];\n        my $dist = $distances->[$j];\n\n        {\n            my $len_idx = $LENGTH_INDICES[$len];\n            my ($min, $bits) = @{$LENGTH_SYMBOLS[$len_idx]};\n\n            push @len_symbols, $len_idx + 256;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $len - $min);\n            }\n        }\n\n        {\n            my $dist_idx = $DISTANCE_INDICES[$dist];\n            my ($min, $bits) = @{$DISTANCE_SYMBOLS[$dist_idx]};\n\n            push @dist_symbols, $dist_idx;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $dist - $min);\n            }\n        }\n    }\n\n    create_huffman_entry(\\@len_symbols,  $out_fh);\n    create_huffman_entry(\\@dist_symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n}\n\nsub deflate_decode ($fh) {\n\n    my $len_symbols  = decode_huffman_entry($fh);\n    my $dist_symbols = decode_huffman_entry($fh);\n\n    my $bits_len = 0;\n\n    foreach my $i (@$dist_symbols) {\n        $bits_len += $DISTANCE_SYMBOLS[$i][1];\n    }\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            $bits_len += $LENGTH_SYMBOLS[$i - 256][1];\n        }\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @literals;\n    my @lengths;\n    my @distances;\n\n    my $j = 0;\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            my $dist = $dist_symbols->[$j++];\n            push @literals,  undef;\n            push @lengths,   $LENGTH_SYMBOLS[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS[$i - 256][1], ''));\n            push @distances, $DISTANCE_SYMBOLS[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$dist][1], ''));\n        }\n        else {\n            push @literals,  $i;\n            push @lengths,   0;\n            push @distances, 0;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub lzss_compression ($chunk, $out_fh) {\n    my (@uncompressed, @indices, @lengths);\n    lz77_compression($chunk, \\@uncompressed, \\@indices, \\@lengths);\n\n    my $est_ratio = length($chunk) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices));\n    say scalar(@uncompressed), ' -> ', $est_ratio;\n\n    deflate_encode(\\@uncompressed, \\@indices, \\@lengths, $out_fh);\n}\n\nsub lzss_decompression ($fh, $out_fh) {\n    my ($uncompressed, $indices, $lengths) = deflate_decode($fh);\n    print $out_fh lz77_decompression($uncompressed, $indices, $lengths);\n}\n\nsub run_length ($arr) {\n\n    @$arr || return [];\n\n    my @result     = [$arr->[0], 1];\n    my $prev_value = $arr->[0];\n\n    foreach my $i (1 .. $#{$arr}) {\n\n        my $curr_value = $arr->[$i];\n\n        if ($curr_value eq $prev_value) {\n            ++$result[-1][1];\n        }\n        else {\n            push(@result, [$curr_value, 1]);\n        }\n\n        $prev_value = $curr_value;\n    }\n\n    return \\@result;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub VLR_encoding ($bytes) {\n\n    my $uncompressed = '';\n    my $bitstream    = '';\n    my $rle          = run_length($bytes);\n\n    foreach my $cv (@$rle) {\n        my ($c, $v) = @$cv;\n        $uncompressed .= $c;\n        if ($v == 1) {\n            $bitstream .= '0';\n        }\n        else {\n            my $t = sprintf('%b', $v);\n            $bitstream .= join('', '1' x (length($t) - 1), '0', substr($t, 1));\n        }\n    }\n\n    return ($uncompressed, pack('B*', $bitstream));\n}\n\nsub VLR_decoding ($uncompressed, $bits_fh) {\n\n    my $decoded = '';\n    my $buffer  = '';\n\n    foreach my $c (@$uncompressed) {\n\n        my $bl = 0;\n        while (read_bit($bits_fh, \\$buffer) == 1) {\n            ++$bl;\n        }\n\n        if ($bl > 0) {\n            $decoded .= $c x oct('0b1' . join('', map { read_bit($bits_fh, \\$buffer) } 1 .. $bl));\n        }\n        else {\n            $decoded .= $c;\n        }\n    }\n\n    return $decoded;\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my ($bwt,          $idx)     = bwt_encode(pack('C*', @{rle4_encode([unpack('C*', $chunk)])}));\n        my ($uncompressed, $lengths) = VLR_encoding([split(//, $bwt)]);\n\n        print $out_fh pack('N', $idx);\n\n        lzss_compression($uncompressed, $out_fh);\n        lzss_compression($lengths,      $out_fh);\n    }\n\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my $uncompressed = '';\n        my $lengths      = '';\n\n        open my $uc_fh,  '>:raw',  \\$uncompressed;\n        open my $len_fh, '+>:raw', \\$lengths;\n\n        my $idx = unpack('N', join('', map { getc($fh) // die \"decompression error\" } 1 .. 4));\n\n        lzss_decompression($fh, $uc_fh);     # uncompressed\n        lzss_decompression($fh, $len_fh);    # lengths\n\n        seek($len_fh, 0, 0);\n\n        my $dec = VLR_decoding([split(//, $uncompressed)], $len_fh);\n        print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode($dec, $idx))])});\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/bwrm_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 10 September 2023\n# Edit: 29 February 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Run-Length encoding + MTF + ZRLE.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\n\nuse constant {\n    PKGNAME => 'BWRM',\n    VERSION => '0.01',\n    FORMAT  => 'bwrm',\n\n    CHUNK_SIZE    => 1 << 17,    # higher value = better compression\n    LOOKAHEAD_LEN => 128,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    say \"Encoded length: $enc_len\";\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        if ($enc == 0) {\n            $populated <<= 1;\n        }\n        else {\n            ($populated <<= 1) |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta), \"\\n\";\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh) // die \"error\")));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\nsub bz2_compression ($chunk, $out_fh, $with_bwt = 0) {\n\n    my @bytes = $with_bwt\n      ? do {\n        my ($bwt, $idx) = bwt_encode(pack('C*', @$chunk));\n        say \"BWT index = $idx\";\n        print $out_fh pack('N', $idx);\n        unpack('C*', $bwt);\n      }\n      : @$chunk;\n\n    my @alphabet     = sort { $a <=> $b } uniq(@bytes);\n    my $alphabet_enc = encode_alphabet(\\@alphabet);\n\n    my $mtf  = mtf_encode(\\@bytes, [@alphabet]);\n    my $rle4 = rle4_encode($mtf);\n    my $rle  = rle_encode($rle4);\n\n    print $out_fh $alphabet_enc;\n    create_huffman_entry($rle, $out_fh);\n}\n\nsub bz2_decompression ($fh, $out_fh, $with_bwt = 0) {\n\n    my $idx      = $with_bwt ? unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)) : 0;\n    my $alphabet = decode_alphabet($fh);\n\n    say \"BWT index = $idx\" if $with_bwt;\n    say \"Alphabet size: \", scalar(@$alphabet);\n\n    my $rle   = decode_huffman_entry($fh);\n    my $rle4  = rle_decode($rle);\n    my $mtf   = rle4_decode($rle4);\n    my $bwt   = mtf_decode($mtf, $alphabet);\n    my @bytes = $with_bwt ? unpack('C*', bwt_decode(pack('C*', @$bwt), $idx)) : @$bwt;\n    print $out_fh pack('C*', @bytes);\n}\n\nsub run_length ($arr) {\n\n    @$arr || return [];\n\n    my @result     = [$arr->[0], 1];\n    my $prev_value = $arr->[0];\n\n    foreach my $i (1 .. $#{$arr}) {\n\n        my $curr_value = $arr->[$i];\n\n        if ($curr_value eq $prev_value and $result[-1][1] < 256) {\n            ++$result[-1][1];\n        }\n        else {\n            push(@result, [$curr_value, 1]);\n        }\n\n        $prev_value = $curr_value;\n    }\n\n    return \\@result;\n}\n\nsub VLR_encoding ($bytes) {\n\n    my @lengths;\n    my @uncompressed;\n\n    my $rle = run_length($bytes);\n\n    foreach my $cv (@$rle) {\n        my ($c, $v) = @$cv;\n        push @uncompressed, ord($c);\n        push @lengths,      $v - 1;\n    }\n\n    return (\\@uncompressed, \\@lengths);\n}\n\nsub VLR_decoding ($uncompressed, $lengths) {\n\n    my $decoded = '';\n\n    foreach my $i (0 .. $#{$uncompressed}) {\n\n        my $c   = $uncompressed->[$i];\n        my $len = $lengths->[$i];\n\n        if ($len > 0) {\n            $decoded .= $c x ($len + 1);\n        }\n        else {\n            $decoded .= $c;\n        }\n    }\n\n    return $decoded;\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my ($bwt,          $idx)     = bwt_encode(pack('C*', @{rle4_encode([unpack('C*', $chunk)])}));\n        my ($uncompressed, $lengths) = VLR_encoding([split(//, $bwt)]);\n\n        print $out_fh pack('N', $idx);\n\n        bz2_compression($uncompressed, $out_fh);\n        create_huffman_entry(rle4_encode($lengths), $out_fh);\n    }\n\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my $uncompressed = '';\n        open my $uc_fh, '>:raw', \\$uncompressed;\n\n        my $idx = unpack('N', join('', map { getc($fh) // die \"decompression error\" } 1 .. 4));\n\n        bz2_decompression($fh, $uc_fh);    # uncompressed\n\n        my $lengths = rle4_decode(decode_huffman_entry($fh));\n        my $dec     = VLR_decoding([split(//, $uncompressed)], $lengths);\n        print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode($dec, $idx))])});\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/bwt2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 14 June 2023\n# Edit: 19 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-To-Front transform (MTF) + Run-length encoding (RLE) + Bzip2.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\n\nuse constant {\n    PKGNAME => 'BWT2',\n    VERSION => '0.01',\n    FORMAT  => 'bwt2',\n\n    CHUNK_SIZE    => 1 << 17,\n    LOOKAHEAD_LEN => 128,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for (0, 1) }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n    say \"Max symbol: $max_symbol\\n\";\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    say \"Encoded length: $enc_len\\n\";\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        if ($enc == 0) {\n            $populated <<= 1;\n        }\n        else {\n            ($populated <<= 1) |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta);\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh))));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\nsub bwt_sort_symbolic ($s) {    # O(n) space (slowish)\n\n    my @cyclic = @$s;\n    my $len    = scalar(@cyclic);\n\n    my $rle = 1;\n    foreach my $i (1 .. $len - 1) {\n        if ($cyclic[$i] != $cyclic[$i - 1]) {\n            $rle = 0;\n            last;\n        }\n    }\n\n    $rle && return [0 .. $len - 1];\n\n    [\n     sort {\n         my ($i, $j) = ($a, $b);\n\n         while ($cyclic[$i] == $cyclic[$j]) {\n             $i %= $len if (++$i >= $len);\n             $j %= $len if (++$j >= $len);\n         }\n\n         $cyclic[$i] <=> $cyclic[$j];\n       } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode_symbolic ($s) {\n\n    my $bwt = bwt_sort_symbolic($s);\n    my @ret = map { $s->[$_ - 1] } @$bwt;\n\n    my $idx = 0;\n    foreach my $i (@$bwt) {\n        $i || last;\n        ++$idx;\n    }\n\n    return (\\@ret, $idx);\n}\n\nsub bwt_decode_symbolic ($bwt, $idx) {    # fast inversion\n\n    my @tail = @$bwt;\n    my @head = sort { $a <=> $b } @tail;\n\n    my @indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices[$tail[$i]]}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices[$v]});\n    }\n\n    my @dec;\n    my $i = $idx;\n\n    for (1 .. scalar(@head)) {\n        push @dec, $head[$i];\n        $i = $table[$i];\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet_symbolic ($alphabet) {\n    return delta_encode([@$alphabet]);\n}\n\nsub decode_alphabet_symbolic ($fh) {\n    return [@{delta_decode($fh)}];\n}\n\nsub bz2_compression_symbolic ($symbols, $out_fh) {\n\n    my $rle4 = rle4_encode($symbols);\n    my ($bwt, $idx) = bwt_encode_symbolic($rle4);\n\n    my @bytes        = @$bwt;\n    my @alphabet     = sort { $a <=> $b } uniq(@bytes);\n    my $alphabet_enc = encode_alphabet_symbolic(\\@alphabet);\n\n    say \"BWT index = $idx\";\n    say \"Max symbol: \", max(@alphabet) // 0;\n\n    my $mtf = mtf_encode(\\@bytes, [@alphabet]);\n    my $rle = rle_encode($mtf);\n\n    print $out_fh pack('N', $idx);\n    print $out_fh $alphabet_enc;\n    create_huffman_entry($rle, $out_fh);\n}\n\nsub bz2_decompression_symbolic ($fh) {\n\n    my $idx      = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    my $alphabet = decode_alphabet_symbolic($fh);\n\n    say \"BWT index = $idx\";\n    say \"Alphabet size: \", scalar(@$alphabet);\n\n    my $rle  = decode_huffman_entry($fh);\n    my $mtf  = rle_decode($rle);\n    my $bwt  = mtf_decode($mtf, $alphabet);\n    my $data = bwt_decode_symbolic($bwt, $idx);\n\n    return rle4_decode($data);\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my $rle4 = rle4_encode([unpack('C*', $chunk)]);\n    my ($bwt, $idx) = bwt_encode(pack('C*', @$rle4));\n\n    say \"BWT index = $idx\";\n\n    my @bytes        = unpack('C*', $bwt);\n    my @alphabet     = sort { $a <=> $b } uniq(@bytes);\n    my $alphabet_enc = encode_alphabet(\\@alphabet);\n\n    my $mtf = mtf_encode(\\@bytes, [@alphabet]);\n    my $rle = rle_encode($mtf);\n\n    print $out_fh pack('N', $idx);\n    print $out_fh $alphabet_enc;\n\n    my @alphabet2 = sort { $a <=> $b } uniq(@$rle);\n    my $mtf2      = mtf_encode([@$rle], [@alphabet2]);\n    my $rle2      = rle4_encode($mtf2);\n\n    my @alphabet3 = sort { $a <=> $b } uniq(@$rle2);\n    my $mtf3      = mtf_encode([@$rle2], [@alphabet3]);\n\n    print $out_fh encode_alphabet_symbolic(\\@alphabet2);\n    print $out_fh encode_alphabet_symbolic(\\@alphabet3);\n\n    bz2_compression_symbolic($mtf3, $out_fh);\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $idx       = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4));\n    my $alphabet  = decode_alphabet($fh);\n    my $alphabet2 = decode_alphabet_symbolic($fh);\n    my $alphabet3 = decode_alphabet_symbolic($fh);\n\n    say \"BWT index = $idx\";\n    say \"Alphabet size: \", scalar(@$alphabet);\n\n    my $mtf3 = bz2_decompression_symbolic($fh);\n    my $rle2 = mtf_decode($mtf3, $alphabet3);\n    my $mtf2 = rle4_decode($rle2);\n    my $rle  = mtf_decode($mtf2, $alphabet2);\n    my $mtf  = rle_decode($rle);\n    my $bwt  = mtf_decode($mtf, $alphabet);\n    my $rle4 = bwt_decode(pack('C*', @$bwt), $idx);\n    my $data = rle4_decode([unpack('C*', $rle4)]);\n\n    print $out_fh pack('C*', @$data);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/bwt_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 14 June 2023\n# Edit: 25 February 2026\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-Front Transform + Run-length encoding + Huffman coding.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\n# Implementation featuring:\n#   1. BWT ENCODE        - O(n * LOOKAHEAD_LEN) space\n#   2. HUFFMAN TREE      – O(n log n) binary min-heap priority queue.\n#   3. HUFFMAN DECODE    – O(n · avg_code_len) trie traversal.\n#   4. BWT INVERSION     – O(n) counting-sort for the next-table.\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\n\nuse constant {\n              PKGNAME       => 'BWT',\n              VERSION       => '0.03',\n              FORMAT        => 'bwt',\n              CHUNK_SIZE    => 1 << 17,    # 128 KiB\n              LOOKAHEAD_LEN => 128,\n             };\n\nuse constant SIGNATURE => uc(FORMAT) . chr(2);\n\n# ---------------------------------------------------------------------------\n# CLI boilerplate\n# ---------------------------------------------------------------------------\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive ($fh) {\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# ---------------------------------------------------------------------------\n# Bit-level I/O\n# ---------------------------------------------------------------------------\n\nsub read_bit ($fh, $bitstring) {\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n    $data = substr($data, 0, $bits_len) if (length($data) > $bits_len);\n    return $data;\n}\n\n# ---------------------------------------------------------------------------\n# Delta coding\n# ---------------------------------------------------------------------------\n\nsub delta_encode ($integers, $double = 0) {\n    my @deltas;\n    my $prev = 0;\n\n    unshift @$integers, scalar(@$integers);\n\n    while (@$integers) {\n        my $curr = shift @$integers;\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . ($d < 0 ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . ($d < 0 ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $sign = read_bit($fh, \\$buffer);\n            my $bl   = 0;\n            ++$bl while read_bit($fh, \\$buffer) eq '1';\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n            push @deltas, ($sign eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $sign = read_bit($fh, \\$buffer);\n            my $n    = 0;\n            ++$n while read_bit($fh, \\$buffer) eq '1';\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($sign eq '1' ? $d : -$d);\n        }\n\n        $len = pop(@deltas) if $k == 0;\n    }\n\n    my @acc;\n    my $prev = $len;\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n    return \\@acc;\n}\n\n# ---------------------------------------------------------------------------\n# Huffman – binary min-heap priority queue\n# ---------------------------------------------------------------------------\n\nsub _heap_push ($heap, $item) {\n    push @$heap, $item;\n    my $i = $#$heap;\n    while ($i > 0) {\n        my $p = ($i - 1) >> 1;\n        last if ($heap->[$p][1] <= $heap->[$i][1]);\n        @{$heap}[$p, $i] = @{$heap}[$i, $p];\n        $i = $p;\n    }\n}\n\nsub _heap_pop ($heap) {\n    return pop @$heap if (@$heap == 1);\n    my $top = $heap->[0];\n    $heap->[0] = pop @$heap;\n    my $n = scalar @$heap;\n    my $i = 0;\n    while (1) {\n        my $s = $i;\n        my $l = 2 * $i + 1;\n        my $r = $l + 1;\n        $s = $l if ($l < $n && $heap->[$l][1] < $heap->[$s][1]);\n        $s = $r if ($r < $n && $heap->[$r][1] < $heap->[$s][1]);\n        last if $s == $i;\n        @{$heap}[$i, $s] = @{$heap}[$s, $i];\n        $i = $s;\n    }\n    return $top;\n}\n\nsub walk ($node, $code, $h, $rev_h) {\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for (0, 1) }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n    return ($h, $rev_h);\n}\n\nsub mktree_from_freq ($freq) {\n    my @heap;\n    _heap_push(\\@heap, [$_, $freq->{$_}])\n      for sort { $a <=> $b } keys %$freq;\n\n    while (@heap > 1) {\n        my $x = _heap_pop(\\@heap);\n        my $y = _heap_pop(\\@heap);\n        _heap_push(\\@heap, [[$x, $y], $x->[1] + $y->[1]]);\n    }\n\n    if (@heap == 1 && !ref $heap[0][0]) {\n        @heap = ([[$heap[0]], $heap[0][1]]);\n    }\n\n    return walk($heap[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\n# ---------------------------------------------------------------------------\n# Huffman decode via trie traversal\n# ---------------------------------------------------------------------------\n\nsub _build_trie ($rev_h) {\n    my $root = {};\n    for my $code (keys %$rev_h) {\n        my $node = $root;\n        for my $bit (split //, $code) {\n            $node->{$bit} //= {};\n            $node = $node->{$bit};\n        }\n        $node->{sym} = $rev_h->{$code};\n    }\n    return $root;\n}\n\nsub huffman_decode ($bits, $rev_h) {\n    my $root = _build_trie($rev_h);\n    my @result;\n    my $node = $root;\n    foreach my $i (0 .. length($bits) - 1) {\n        my $bit = substr($bits, $i, 1);\n        $node = $node->{$bit};\n        if (exists $node->{sym}) {\n            push @result, $node->{sym};\n            $node = $root;\n        }\n    }\n    return \\@result;\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc        = huffman_encode($bytes, $h);\n    my $max_symbol = max(keys %freq) // 0;\n    say \"Max symbol: $max_symbol\\n\";\n\n    my @freqs;\n    push @freqs, ($freq{$_} // 0) for 0 .. $max_symbol;\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack('N',  length($enc));\n    print $out_fh pack('B*', $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    for my $i (0 .. $#freqs) {\n        $freq{$i} = $freqs[$i] if $freqs[$i];\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    say \"Encoded length: $enc_len\\n\";\n\n    return (\n            ($enc_len > 0)\n            ? huffman_decode(read_bits($fh, $enc_len), $rev_dict)\n            : []\n           );\n}\n\n# ---------------------------------------------------------------------------\n# Move-to-Front\n# ---------------------------------------------------------------------------\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n    my @C;\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    for my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift @$alphabet, splice(@$alphabet, $index, 1);\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n    my @S;\n    for my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift @$alphabet, splice(@$alphabet, $p, 1);\n    }\n    return \\@S;\n}\n\n# ---------------------------------------------------------------------------\n# BWT construction\n# ---------------------------------------------------------------------------\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;      # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map { $_->[1] }\n        sort {\n            ($a->[0] cmp $b->[0])\n              || do {\n                my ($cmp, $s_len) = (0, LOOKAHEAD_LEN << 2);\n                while (1) {\n                    ($cmp = substr($double_s, $a->[1], $s_len) cmp substr($double_s, $b->[1], $s_len)) && last;\n                    $s_len <<= 1;\n                }\n                $cmp;\n            }\n        }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\n# ---------------------------------------------------------------------------\n# BWT inversion with counting sort\n# ---------------------------------------------------------------------------\n\nsub bwt_decode ($bwt, $idx) {\n    my @L = unpack('C*', $bwt);\n    my $n = scalar @L;\n\n    my @freq = (0) x 256;\n    $freq[$_]++ for @L;\n\n    my @cumul = (0) x 257;\n    $cumul[$_ + 1] = $cumul[$_] + $freq[$_] for 0 .. 255;\n\n    my @next;\n    my @cnt = (0) x 256;\n    for my $i (0 .. $n - 1) {\n        $next[$cumul[$L[$i]] + $cnt[$L[$i]]++] = $i;\n    }\n\n    my @dec;\n    my $i = $idx;\n    for (1 .. $n) {\n        $i = $next[$i];\n        push @dec, $L[$i];\n    }\n\n    return pack('C*', @dec);\n}\n\n# ---------------------------------------------------------------------------\n# Run-length encoding stages\n# ---------------------------------------------------------------------------\n\nsub rle4_encode ($bytes) {\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            $run = 0;\n            ++$i;\n            while ($run < 255 && $i <= $end && $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n            push @rle, $run;\n            $run = 1;\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, ($prev) x $run;\n            }\n            $run = 0;\n        }\n    }\n    return \\@dec;\n}\n\nsub rle_encode ($bytes) {\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $run = 0;\n        while ($i <= $end && $bytes->[$i] == 0) { ++$run; ++$i }\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n        push @rle, $bytes->[$i] + 1 if $i <= $end;\n    }\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n        if ($k == 0 || $k == 1) {\n            my $run = 1;\n            while ($i <= $end && ($k == 0 || $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n        push @dec, $k - 1 if $i <= $end;\n    }\n    return \\@dec;\n}\n\n# ---------------------------------------------------------------------------\n# Alphabet encoding / decoding\n# ---------------------------------------------------------------------------\n\nsub encode_alphabet ($alphabet) {\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        my $enc = 0;\n        $enc |= 1 << $_ for grep { exists $table{$i + $_} } 0 .. 31;\n\n        if ($enc == 0) { $populated <<= 1 }\n        else           { ($populated <<= 1) |= 1; push @marked, $enc }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta);\n\n    return chr($populated) . $delta;\n}\n\nsub decode_alphabet ($fh) {\n    my @populated = split(//, sprintf('%08b', ord(getc($fh))));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift @populated) {\n            my $m = shift @$marked;\n            for my $j (0 .. 31) {\n                push @alphabet, $i + $j if $m & 1;\n                $m >>= 1;\n            }\n        }\n    }\n    return \\@alphabet;\n}\n\n# ---------------------------------------------------------------------------\n# Top-level compression / decompression passes\n# ---------------------------------------------------------------------------\n\nsub compression ($chunk, $out_fh) {\n    my $rle1 = rle4_encode([unpack('C*', $chunk)]);\n    my ($bwt, $idx) = bwt_encode(pack('C*', @$rle1));\n\n    say \"BWT index = $idx\";\n\n    my @bytes        = unpack('C*', $bwt);\n    my @alphabet     = sort { $a <=> $b } uniq(@bytes);\n    my $alphabet_enc = encode_alphabet(\\@alphabet);\n\n    my $mtf = mtf_encode(\\@bytes, [@alphabet]);\n    my $rle = rle_encode($mtf);\n\n    print $out_fh pack('N', $idx);\n    print $out_fh $alphabet_enc;\n    create_huffman_entry($rle, $out_fh);\n}\n\nsub decompression ($fh, $out_fh) {\n    my $idx      = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4));\n    my $alphabet = decode_alphabet($fh);\n\n    say \"BWT index = $idx\";\n    say \"Alphabet size: \", scalar(@$alphabet);\n\n    my $rle  = decode_huffman_entry($fh);\n    my $mtf  = rle_decode($rle);\n    my $bwt  = mtf_decode($mtf, $alphabet);\n    my $rle4 = bwt_decode(pack('C*', @$bwt), $idx);\n    my $data = rle4_decode([unpack('C*', $rle4)]);\n\n    print $out_fh pack('C*', @$data);\n}\n\n# ---------------------------------------------------------------------------\n# File-level entry points\n# ---------------------------------------------------------------------------\n\nsub compress_file ($input, $output) {\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    print $out_fh SIGNATURE;\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n    close $out_fh;\n}\n\nsub decompress_file ($input, $output) {\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh)\n      || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit 0;\n"
  },
  {
    "path": "Compression/bww_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 June 2023\n# Edit: 16 June 2023\n# https://github.com/trizen\n\n# Compress/decompress files using Burrows-Wheeler Transform (BWT) + LZW compression.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Lempel%E2%80%93Ziv%E2%80%93Welch\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\n\nuse constant {\n    PKGNAME => 'BWW',\n    VERSION => '0.02',\n    FORMAT  => 'bww',\n\n    CHUNK_SIZE    => 1 << 17,    # higher value = better compression\n    LOOKAHEAD_LEN => 128,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(2);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 254 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        if ($enc == 0) {\n            $populated <<= 1;\n        }\n        else {\n            ($populated <<= 1) |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked]);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta);\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh))));\n    my $marked    = delta_decode($fh);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\n# Compress a string to a list of output symbols\nsub compress ($uncompressed) {\n\n    # Build the dictionary\n    my $dict_size = 256;\n    my %dictionary;\n\n    foreach my $i (0 .. $dict_size - 1) {\n        $dictionary{chr($i)} = $i;\n    }\n\n    my $w = '';\n    my @result;\n\n    foreach my $c (split(//, $uncompressed)) {\n        my $wc = $w . $c;\n        if (exists $dictionary{$wc}) {\n            $w = $wc;\n        }\n        else {\n            push @result, $dictionary{$w};\n\n            # Add wc to the dictionary\n            $dictionary{$wc} = $dict_size++;\n            $w = $c;\n        }\n    }\n\n    # Output the code for w\n    if ($w ne '') {\n        push @result, $dictionary{$w};\n    }\n\n    return \\@result;\n}\n\n# Decompress a list of output ks to a string\nsub decompress ($compressed) {\n\n    # Build the dictionary\n    my $dict_size  = 256;\n    my @dictionary = map { chr($_) } 0 .. $dict_size - 1;\n\n    my $w      = $dictionary[$compressed->[0]];\n    my $result = $w;\n\n    foreach my $j (1 .. $#{$compressed}) {\n        my $k = $compressed->[$j];\n\n        my $entry =\n            ($k < $dict_size)  ? $dictionary[$k]\n          : ($k == $dict_size) ? ($w . substr($w, 0, 1))\n          :                      die \"Bad compressed k: $k\";\n\n        $result .= $entry;\n\n        # Add w+entry[0] to the dictionary\n        push @dictionary, $w . substr($entry, 0, 1);\n        ++$dict_size;\n        $w = $entry;\n    }\n\n    return $result;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub elias_encoding ($integers) {\n\n    my $bitstring = '';\n    foreach my $k (scalar(@$integers), @$integers) {\n        if ($k == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', $k + 1);\n            my $l = length($t);\n            my $L = sprintf('%b', $l);\n            $bitstring .= ('1' x (length($L) - 1)) . '0' . substr($L, 1) . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub elias_decoding ($fh) {\n\n    my @ints;\n    my $len    = 0;\n    my $buffer = '';\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n\n        my $bl = 0;\n        ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n        if ($bl > 0) {\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @ints, $int - 1;\n        }\n        else {\n            push @ints, 0;\n        }\n\n        if ($k == 0) {\n            $len = pop(@ints);\n        }\n    }\n\n    return \\@ints;\n}\n\nsub encode_integers ($integers) {\n\n    my @counts;\n    my $count           = 0;\n    my $bits_width      = 1;\n    my $bits_max_symbol = 1 << $bits_width;\n    my $processed_len   = 0;\n\n    foreach my $k (@$integers) {\n        while ($k >= $bits_max_symbol) {\n\n            if ($count > 0) {\n                push @counts, [$bits_width, $count];\n                $processed_len += $count;\n            }\n\n            $count = 0;\n            $bits_max_symbol *= 2;\n            $bits_width      += 1;\n        }\n        ++$count;\n    }\n\n    push @counts, grep { $_->[1] > 0 } [$bits_width, scalar(@$integers) - $processed_len];\n\n    my $compressed = elias_encoding([(map { $_->[0] } @counts), (map { $_->[1] } @counts)]);\n\n    my $bits = '';\n    foreach my $pair (@counts) {\n        my ($blen, $len) = @$pair;\n        foreach my $symbol (splice(@$integers, 0, $len)) {\n            $bits .= sprintf(\"%0*b\", $blen, $symbol);\n        }\n    }\n\n    $compressed .= pack('B*', $bits);\n    return $compressed;\n}\n\nsub decode_integers ($fh) {\n\n    my $ints = elias_decoding($fh);\n    my $half = scalar(@$ints) >> 1;\n\n    my @counts;\n    foreach my $i (0 .. ($half - 1)) {\n        push @counts, [$ints->[$i], $ints->[$half + $i]];\n    }\n\n    my $bits_len = 0;\n\n    foreach my $pair (@counts) {\n        my ($blen, $len) = @$pair;\n        $bits_len += $blen * $len;\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @integers;\n    foreach my $pair (@counts) {\n        my ($blen, $len) = @$pair;\n        foreach my $chunk (unpack(sprintf('(a%d)*', $blen), substr($bits, 0, $blen * $len, ''))) {\n            push @integers, oct('0b' . $chunk);\n        }\n    }\n\n    return \\@integers;\n}\n\nsub delta_encode ($integers) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my $data = pack('C*', @{rle4_encode([unpack('C*', $chunk)])});\n        my ($bwt, $idx) = bwt_encode($data);\n\n        my @bytes        = unpack('C*', $bwt);\n        my @alphabet     = sort { $a <=> $b } uniq(@bytes);\n        my $alphabet_enc = encode_alphabet(\\@alphabet);\n\n        say \"# symbols : \", scalar(@alphabet), \"\\n\";\n\n        my $enc_bytes = mtf_encode(\\@bytes, [@alphabet]);\n\n        if (max(@$enc_bytes) < 255) {\n            print $out_fh chr(1);\n            $enc_bytes = rle_encode($enc_bytes);\n        }\n        else {\n            print $out_fh chr(0);\n            $enc_bytes = rle4_encode($enc_bytes);\n        }\n\n        my $lzw = compress(pack('C*', @$enc_bytes));\n\n        print $out_fh pack('N', $idx);\n        print $out_fh $alphabet_enc;\n        print $out_fh encode_integers($lzw);\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my $rle_encoded = ord(getc($fh) // die \"error\");\n        my $idx         = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n        my $alphabet    = decode_alphabet($fh);\n        my $lzw         = decode_integers($fh);\n\n        my $bytes = [unpack('C*', decompress($lzw))];\n\n        if ($rle_encoded) {\n            $bytes = rle_decode($bytes);\n        }\n        else {\n            $bytes = rle4_decode($bytes);\n        }\n\n        $bytes = mtf_decode($bytes, [@$alphabet]);\n\n        print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode(pack('C*', @$bytes), $idx))])});\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/bzip2_compressor.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 20 August 2024\n# https://github.com/trizen\n\n# A very basic Bzip2 compressor.\n\n# References:\n#   BZIP2: Format Specification, by Joe Tsai\n#   https://github.com/dsnet/compress/blob/master/doc/bzip2-format.pdf\n\nuse 5.036;\nuse POSIX             qw(ceil);\nuse List::Util        qw(max);\nuse Compression::Util qw(:all);\n\nuse constant {CHUNK_SIZE => 1 << 17};\n\nlocal $| = 1;\n\nbinmode(STDIN,  \":raw\");\nbinmode(STDOUT, \":raw\");\n\nsub encode_mtf_alphabet($alphabet) {\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 16) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 15) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        $populated <<= 1;\n\n        if ($enc > 0) {\n            $populated |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    say STDERR sprintf(\"Populated: %016b\", $populated);\n    say STDERR \"Marked: (@marked)\";\n\n    return ($populated, \\@marked);\n}\n\nsub encode_code_lengths($dict) {\n    my @lengths;\n\n    foreach my $symbol (0 .. max(keys %$dict) // 0) {\n        if (exists($dict->{$symbol})) {\n            push @lengths, length($dict->{$symbol});\n        }\n        else {\n            die \"Incomplete Huffman tree not supported\";\n            push @lengths, 0;\n        }\n    }\n\n    say STDERR \"Code lengths: (@lengths)\";\n\n    my $deltas = deltas(\\@lengths);\n    say STDERR \"Code lengths deltas: (@$deltas)\";\n    my $bitstring = int2bits(shift(@$deltas), 5) . '0';\n\n    foreach my $d (@$deltas) {\n        $bitstring .= (($d > 0) ? ('10' x $d) : ('11' x abs($d))) . '0';\n    }\n\n    say STDERR \"Deltas bitstring: $bitstring\";\n\n    return $bitstring;\n}\n\nmy $s = \"Hello, World!\\n\";\n\nmy $fh;\nif (-t STDIN) {\n    open $fh, \"<:raw\", \\$s;\n}\nelse {\n    $fh = \\*STDIN;\n}\n\nprint \"BZh\";\n\nmy $level = 9;\n\nif ($level <= 0 or $level > 9) {\n    die \"Invalid level value: $level\";\n}\n\nprint $level;\n\nmy $block_header_bitstring = unpack(\"B48\", \"1AY&SY\");\nmy $block_footer_bitstring = unpack(\"B48\", \"\\27rE8P\\x90\");\n\nmy $bitstring    = '';\nmy $stream_crc32 = 0;\n\nwhile (!eof($fh)) {\n\n    read($fh, (my $chunk), CHUNK_SIZE);\n\n    $bitstring .= $block_header_bitstring;\n\n    my $crc32 = crc32(pack 'B*', unpack 'b*', $chunk);\n    say STDERR \"CRC32: $crc32\";\n\n    $crc32 = oct('0b' . int2bits_lsb($crc32, 32));\n    say STDERR \"Bzip2-CRC32: $crc32\";\n\n    $stream_crc32 = ($crc32 ^ (0xffffffff & ((0xffffffff & ($stream_crc32 << 1)) | (($stream_crc32 >> 31) & 0x1)))) & 0xffffffff;\n    $bitstring .= int2bits($crc32, 32);\n    $bitstring .= '0';                    # not randomized\n\n    my $rle4 = rle4_encode($chunk);\n    ##say STDERR \"RLE4: (@$rle4)\";\n    my ($bwt, $bwt_idx) = bwt_encode(symbols2string($rle4));\n\n    $bitstring .= int2bits($bwt_idx, 24);\n\n    my ($mtf, $alphabet) = mtf_encode($bwt);\n    ##say STDERR \"MTF: (@$mtf)\";\n    say STDERR \"MTF Alphabet: (@$alphabet)\";\n\n    my ($populated, $marked) = encode_mtf_alphabet($alphabet);\n\n    $bitstring .= int2bits($populated, 16);\n    $bitstring .= int2bits_lsb($_, 16) for @$marked;\n\n    my @zrle = reverse @{zrle_encode([reverse @$mtf])};\n    ##say STDERR \"ZRLE: @zrle\";\n\n    my $eob = scalar(@$alphabet) + 1;    # end-of-block symbol\n    say STDERR \"EOB symbol: $eob\";\n    push @zrle, $eob;\n\n    my ($dict) = huffman_from_symbols([@zrle, 0 .. $eob - 1]);\n    my $num_sels = ceil(scalar(@zrle) / 50);\n    say STDERR \"Number of selectors: $num_sels\";\n\n    $bitstring .= int2bits(2,         3);\n    $bitstring .= int2bits($num_sels, 15);\n    $bitstring .= '0' x $num_sels;\n\n    $bitstring .= encode_code_lengths($dict) x 2;\n    $bitstring .= join('', @{$dict}{@zrle});\n}\n\n$bitstring .= $block_footer_bitstring;\n$bitstring .= int2bits($stream_crc32, 32);\n\nprint pack(\"B*\", $bitstring);\n"
  },
  {
    "path": "Compression/bzip2_decompressor.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 19 August 2024\n# https://github.com/trizen\n\n# A very basic Bzip2 decompressor.\n\n# References:\n#   BZIP2: Format Specification, by Joe Tsai\n#   https://github.com/dsnet/compress/blob/master/doc/bzip2-format.pdf\n#\n#   Pyflate, by Paul Sladen\n#   http://www.paul.sladen.org/projects/pyflate/\n\nuse 5.036;\nuse List::Util        qw(max);\nuse Compression::Util qw(:all);\n\nlocal $| = 1;\n\nbinmode(STDIN,  \":raw\");\nbinmode(STDOUT, \":raw\");\n\nmy $s = '';\n\n$s .= \"BZh91AY&SY\\xEA\\xE0\\x8D\\xEB\\0\\0\\0\\xC1\\0\\0\\x100\\0 \\0!\\x98\\31\\x84aw\\$S\\x85\\t\\16\\xAE\\b\\xDE\\xB0\";                                          # \"ab\\n\"\n$s .= \"BZh91AY&SY\\x99\\xAC\\\"V\\0\\0\\2W\\x80\\0\\20`\\4\\0@\\0\\x80\\6\\4\\x90\\0 \\0\\\"\\6\\x81\\x90\\x80i\\xA6\\x89\\30j\\xCE\\xA4\\31o\\x8B\\xB9\\\"\\x9C(HL\\xD6\\21+\\0\";  # \"Hello, World!\\n\"\n\n$s .=\n    \"BZh91AY&SY\\xE9\\xA6L\\xBE\\0\\0\\20\\xC9\\x80\\n\\20\\2\\xE0?\\xFB\\x8B0\"\n  . \" \\0\\x89\\fE2i\\xA3&\\x9A\\3A)\\xEA\\\"'\\xA8h\\3\\xD4\\xD3gxRZ\\4\\x8C\\xDA'g,\\x88\\xD5\\xA6\"\n  . \"\\x9C\\xEA\\xC4\\30wWy\\xE4\\xD7\\xC0\\x95\\xF9L\\x89\\5\\x936'\\xED\\x95a\\22o%B\\x90\\x93\"\n  . \"T\\xAF\\xFD\\xE6\\xEA)\\x8D\\x90\\x82\\xB5\\x9E\\x89Z\\xD7X\\xB19\\x9D0\\xC9\\21s\\x9E\\x95\"\n  . \"\\1\\xB2F\\xE9\\x98\\xFD\\x8A+O\\xAD\\xBDi\\x96s\\e\\0\\4\\xA3G\\xC0\\xB2\\4\\xA6_\\x8B\\xB9\\\"\\x9C(Ht\\xD3&_\\0\";    # some bigger string\n\nmy $fh;\nif (-t STDIN) {\n    open $fh, \"<:raw\", \\$s;\n}\nelse {\n    $fh = \\*STDIN;\n}\n\nwhile (!eof($fh)) {\n\n    my $buffer = '';\n\n    (bytes2int($fh, 2) == 0x425a and getc($fh) eq 'h')\n      or die \"Not a valid Bzip2 archive\";\n\n    my $level = getc($fh) + 0;\n\n    if (not $level) {\n        die \"invalid level\";\n    }\n\n    say STDERR \"Compression level: $level\";\n\n    my $stream_crc32 = 0;\n\n    while (!eof($fh)) {\n\n        my $block_magic = pack \"B48\", join('', map { read_bit($fh, \\$buffer) } 1 .. 48);\n\n        if ($block_magic eq \"1AY&SY\") {    # BlockHeader\n            say STDERR \"Block header detected\";\n\n            my $crc32 = bits2int($fh, 32, \\$buffer);\n            say STDERR \"CRC32 = $crc32\";\n\n            my $randomized = read_bit($fh, \\$buffer);\n            $randomized == 0 or die \"randomized not supported\";\n\n            my $bwt_idx = bits2int($fh, 24, \\$buffer);\n            say STDERR \"BWT index: $bwt_idx\";\n\n            my @alphabet;\n            my $l1 = bits2int($fh, 16, \\$buffer);\n            for my $i (0 .. 15) {\n                if ($l1 & (0x8000 >> $i)) {\n                    my $l2 = bits2int($fh, 16, \\$buffer);\n                    for my $j (0 .. 15) {\n                        if ($l2 & (0x8000 >> $j)) {\n                            push @alphabet, 16 * $i + $j;\n                        }\n                    }\n                }\n            }\n\n            say STDERR \"MTF alphabet: (@alphabet)\";\n\n            my $num_trees = bits2int($fh, 3, \\$buffer);\n            say STDERR \"Number or trees: $num_trees\";\n\n            my $num_sels = bits2int($fh, 15, \\$buffer);\n            say STDERR \"Number of selectors: $num_sels\";\n\n            my @idxs;\n            for (1 .. $num_sels) {\n                my $i = 0;\n                while (read_bit($fh, \\$buffer)) {\n                    $i += 1;\n                    ($i < $num_trees) or die \"error\";\n                }\n                push @idxs, $i;\n            }\n\n            my $sels = mtf_decode(\\@idxs, [0 .. $num_trees - 1]);\n            say STDERR \"Selectors: (@$sels)\";\n\n            my $MaxHuffmanBits = 20;\n            my $num_syms       = scalar(@alphabet) + 2;\n\n            my @trees;\n            for (1 .. $num_trees) {\n                my @clens;\n                my $clen = bits2int($fh, 5, \\$buffer);\n                for (1 .. $num_syms) {\n                    while (1) {\n\n                        ($clen > 0 and $clen <= $MaxHuffmanBits)\n                          or warn \"Invalid code length: $clen!\\n\";\n\n                        if (not read_bit($fh, \\$buffer)) {\n                            last;\n                        }\n\n                        $clen -= read_bit($fh, \\$buffer) ? 1 : -1;\n                    }\n\n                    push @clens, $clen;\n                }\n                push @trees, \\@clens;\n                say STDERR \"Code lengths: (@clens)\";\n            }\n\n            foreach my $tree (@trees) {\n                my $maxLen = max(@$tree);\n                my $sum    = 1 << $maxLen;\n                for my $clen (@$tree) {\n                    $sum -= (1 << $maxLen) >> $clen;\n                }\n\n                $sum == 0 or warn \"incomplete tree detected: (@$tree)\\n\";\n            }\n\n            my @huffman_trees = map { (huffman_from_code_lengths($_))[1] } @trees;\n\n            my $eob = @alphabet + 1;\n\n            my @zrle;\n            my $code = '';\n\n            my $sel_idx = 0;\n            my $tree    = $huffman_trees[$sels->[$sel_idx]];\n            my $decoded = 50;\n\n            while (!eof($fh)) {\n                $code .= read_bit($fh, \\$buffer);\n\n                if (length($code) > $MaxHuffmanBits) {\n                    die \"[!] Something went wrong: length of LL code `$code` is > $MaxHuffmanBits.\\n\";\n                }\n\n                if (exists($tree->{$code})) {\n\n                    my $sym = $tree->{$code};\n\n                    if ($sym == $eob) {    # end of block marker\n                        say STDERR \"EOB detected: $sym\";\n                        last;\n                    }\n\n                    push @zrle, $sym;\n                    $code = '';\n\n                    if (--$decoded <= 0) {\n                        if (++$sel_idx <= $#$sels) {\n                            $tree = $huffman_trees[$sels->[$sel_idx]];\n                        }\n                        else {\n                            die \"No more selectors\";    # should not happen\n                        }\n                        $decoded = 50;\n                    }\n                }\n            }\n\n            ##say STDERR \"ZRLE: (@zrle)\";\n            my @mtf = reverse @{zrle_decode([reverse @zrle])};\n            ##say STDERR \"MTF: (@mtf)\";\n\n            my $bwt = symbols2string mtf_decode(\\@mtf, \\@alphabet);\n            ## say \"BWT: ($bwt, $bwt_idx)\";\n\n            my $rle4 = string2symbols bwt_decode($bwt, $bwt_idx);\n            my $data = rle4_decode($rle4);\n            my $dec  = symbols2string($data);\n\n            my $new_crc32 = oct('0b' . int2bits_lsb(crc32(pack('b*', unpack('B*', $dec))), 32));\n\n            say STDERR \"Computed CRC32: $new_crc32\";\n\n            if ($crc32 != $new_crc32) {\n                warn \"CRC32 error: $crc32 (stored) != $new_crc32 (actual)\\n\";\n            }\n\n            $stream_crc32 = ($new_crc32 ^ (0xffffffff & ((0xffffffff & ($stream_crc32 << 1)) | (($stream_crc32 >> 31) & 0x1)))) & 0xffffffff;\n\n            print $dec;\n        }\n        elsif ($block_magic eq \"\\27rE8P\\x90\") {    # BlockFooter\n            say STDERR \"Block footer detected\";\n            my $stored_stream_crc32 = bits2int($fh, 32, \\$buffer);\n            say STDERR \"Stream CRC32: $stored_stream_crc32\";\n\n            if ($stream_crc32 != $stored_stream_crc32) {\n                warn \"Stream CRC32 error: $stored_stream_crc32 (stored) != $stream_crc32 (actual)\\n\";\n            }\n\n            $buffer = '';\n            last;\n        }\n        else {\n            die \"Unknown block magic: $block_magic\";\n        }\n\n    }\n\n    say STDERR \"End of container\";\n}\n\nsay STDERR \"End of input\";\n"
  },
  {
    "path": "Compression/bzip2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 25 August 2024\n# https://github.com/trizen\n\n# A valid Bzip2 file compressor/decompressor.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n#\n#   BZIP2: Format Specification, by Joe Tsai\n#   https://github.com/dsnet/compress/blob/master/doc/bzip2-format.pdf\n#\n#   Pyflate, by Paul Sladen\n#   http://www.paul.sladen.org/projects/pyflate/\n\nuse 5.036;\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\nuse List::Util        qw(max);\nuse Getopt::Std       qw(getopts);\n\nbinmode(STDIN,  \":raw\");\nbinmode(STDOUT, \":raw\");\n\nuse constant {\n              FORMAT     => 'bz2',\n              CHUNK_SIZE => 900_000,    # 900KB blocks for level 9 (standard bzip2)\n             };\n\nsub usage ($code = 0) {\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub encode_code_lengths($dict) {\n    my @lengths;\n\n    foreach my $symbol (0 .. max(keys %$dict) // 0) {\n        if (exists($dict->{$symbol})) {\n            push @lengths, length($dict->{$symbol});\n        }\n        else {\n            die \"Incomplete Huffman tree not supported\";\n            push @lengths, 0;\n        }\n    }\n\n    say STDERR \"Code lengths: (@lengths)\";\n\n    my $deltas = deltas(\\@lengths);\n    say STDERR \"Code lengths deltas: (@$deltas)\";\n    my $bitstring = int2bits(shift(@$deltas), 5) . '0';\n\n    foreach my $d (@$deltas) {\n        $bitstring .= (($d > 0) ? ('10' x $d) : ('11' x abs($d))) . '0';\n    }\n\n    say STDERR \"Deltas bitstring: $bitstring\";\n\n    return $bitstring;\n}\n\nsub my_bzip2_compress($fh, $out_fh) {\n\n    print $out_fh \"BZh\";\n\n    my $level = 9;\n\n    if ($level <= 0 or $level > 9) {\n        die \"Invalid level value: $level\";\n    }\n\n    print $out_fh $level;\n\n    my $block_header_bitstring = unpack(\"B48\", \"1AY&SY\");\n    my $block_footer_bitstring = unpack(\"B48\", \"\\27rE8P\\x90\");\n\n    my $bitstring    = '';\n    my $stream_crc32 = 0;\n\n    while (!eof($fh)) {\n\n        read($fh, (my $chunk), CHUNK_SIZE);\n\n        $bitstring .= $block_header_bitstring;\n\n        my $crc32 = crc32(pack 'B*', unpack 'b*', $chunk);\n        say STDERR \"CRC32: $crc32\";\n\n        $crc32 = oct('0b' . int2bits_lsb($crc32, 32));\n        say STDERR \"Bzip2-CRC32: $crc32\";\n\n        $stream_crc32 = ($crc32 ^ (0xffffffff & ((0xffffffff & ($stream_crc32 << 1)) | (($stream_crc32 >> 31) & 0x1)))) & 0xffffffff;\n        $bitstring .= int2bits($crc32, 32);\n        $bitstring .= '0';                    # not randomized\n\n        my $rle4 = rle4_encode($chunk);\n        ##say STDERR \"RLE4: (@$rle4)\";\n        my ($bwt, $bwt_idx) = bwt_encode(symbols2string($rle4));\n\n        $bitstring .= int2bits($bwt_idx, 24);\n\n        my ($mtf, $alphabet) = mtf_encode($bwt);\n        ##say STDERR \"MTF: (@$mtf)\";\n        say STDERR \"MTF Alphabet: (@$alphabet)\";\n\n        $bitstring .= unpack('B*', encode_alphabet_256($alphabet));\n\n        my @zrle = reverse @{zrle_encode([reverse @$mtf])};\n        ##say STDERR \"ZRLE: @zrle\";\n\n        my $eob = scalar(@$alphabet) + 1;    # end-of-block symbol\n        say STDERR \"EOB symbol: $eob\";\n        push @zrle, $eob;\n\n        # Split ZRLE data into groups of 50 symbols\n        my @groups;\n        for (my $i = 0 ; $i < @zrle ; $i += 50) {\n            my $end = $i + 49;\n            $end = $#zrle if $end > $#zrle;\n            push @groups, [@zrle[$i .. $end]];\n        }\n        my $num_groups = scalar(@groups);\n\n        # Determine number of Huffman tables based on number of groups\n        my $num_trees =\n            ($num_groups <= 1)   ? 2\n          : ($num_groups < 200)  ? 3\n          : ($num_groups < 600)  ? 4\n          : ($num_groups < 1200) ? 5\n          :                        6;\n\n        say STDERR \"Number of trees: $num_trees\";\n\n        # Initial assignment: distribute groups roughly evenly across tables\n        my @assignments;\n        for my $gi (0 .. $#groups) {\n            my $t = int($gi * $num_trees / $num_groups);\n            $t = $num_trees - 1 if $t >= $num_trees;\n            push @assignments, $t;\n        }\n\n        # Full symbol range to ensure complete Huffman trees\n        my @all_syms = (0 .. $eob);\n\n        # Iterative optimization of table assignments\n        my @dicts;\n        for (1 .. 10) {\n\n            # Build symbol list for each table (with full symbol range as baseline)\n            my @sym_lists;\n            for my $t (0 .. $num_trees - 1) {\n                push @sym_lists, [@all_syms];    # Start with all symbols for complete tree\n            }\n            for my $gi (0 .. $#groups) {\n\n                # Add symbols multiple times to increase their weight in frequency calculation\n                push @{$sym_lists[$assignments[$gi]]}, (@{$groups[$gi]}) x 2;    # Double weight\n            }\n\n            # Build Huffman tables from frequencies\n            @dicts = map { (huffman_from_symbols($_))[0] } @sym_lists;\n\n            # Re-assign each group to the best-fitting table\n            my @new_assignments;\n            for my $gi (0 .. $#groups) {\n                my ($best_t, $best_cost) = (0, 9**9**9);\n                for my $t (0 .. $num_trees - 1) {\n                    my $cost = 0;\n                    $cost += length($dicts[$t]{$_} // '') for @{$groups[$gi]};\n                    ($best_t, $best_cost) = ($t, $cost) if $cost < $best_cost;\n                }\n                push @new_assignments, $best_t;\n            }\n\n            last if \"@new_assignments\" eq \"@assignments\";\n            @assignments = @new_assignments;\n        }\n\n        my $num_sels = $num_groups;\n        say STDERR \"Number of selectors: $num_sels\";\n\n        $bitstring .= int2bits($num_trees, 3);\n        $bitstring .= int2bits($num_sels,  15);\n\n        # MTF-encode selectors and write as unary codes\n        my @mtf_list = (0 .. $num_trees - 1);\n        for my $sel (@assignments) {\n            my $pos = 0;\n            $pos++ while $mtf_list[$pos] != $sel;\n            $bitstring .= '1' x $pos . '0';\n            splice(@mtf_list, $pos, 1);\n            unshift @mtf_list, $sel;\n        }\n\n        # Write all Huffman tables\n        $bitstring .= encode_code_lengths($_) for @dicts;\n\n        # Encode symbols group by group using the assigned tables\n        for my $gi (0 .. $#groups) {\n            $bitstring .= join('', @{$dicts[$assignments[$gi]]}{@{$groups[$gi]}});\n        }\n\n        print $out_fh pack('B*', substr($bitstring, 0, length($bitstring) - (length($bitstring) % 8), ''));\n    }\n\n    $bitstring .= $block_footer_bitstring;\n    $bitstring .= int2bits($stream_crc32, 32);\n\n    print $out_fh pack(\"B*\", $bitstring);\n    return 1;\n}\n\nsub my_bzip2_decompress($fh, $out_fh) {\n\n    while (!eof($fh)) {\n\n        my $buffer = '';\n\n        (bytes2int($fh, 2) == 0x425a and getc($fh) eq 'h')\n          or die \"Not a valid Bzip2 archive\";\n\n        my $level = getc($fh) + 0;\n\n        if (not $level) {\n            die \"invalid level\";\n        }\n\n        say STDERR \"Compression level: $level\";\n\n        my $stream_crc32 = 0;\n\n        while (!eof($fh)) {\n\n            my $block_magic = pack \"B48\", join('', map { read_bit($fh, \\$buffer) } 1 .. 48);\n\n            if ($block_magic eq \"1AY&SY\") {    # BlockHeader\n                say STDERR \"Block header detected\";\n\n                my $crc32 = bits2int($fh, 32, \\$buffer);\n                say STDERR \"CRC32 = $crc32\";\n\n                my $randomized = read_bit($fh, \\$buffer);\n                $randomized == 0 or die \"randomized not supported\";\n\n                my $bwt_idx = bits2int($fh, 24, \\$buffer);\n                say STDERR \"BWT index: $bwt_idx\";\n\n                my @alphabet;\n                my $l1 = bits2int($fh, 16, \\$buffer);\n                for my $i (0 .. 15) {\n                    if ($l1 & (0x8000 >> $i)) {\n                        my $l2 = bits2int($fh, 16, \\$buffer);\n                        for my $j (0 .. 15) {\n                            if ($l2 & (0x8000 >> $j)) {\n                                push @alphabet, 16 * $i + $j;\n                            }\n                        }\n                    }\n                }\n\n                say STDERR \"MTF alphabet: (@alphabet)\";\n\n                my $num_trees = bits2int($fh, 3, \\$buffer);\n                say STDERR \"Number or trees: $num_trees\";\n\n                my $num_sels = bits2int($fh, 15, \\$buffer);\n                say STDERR \"Number of selectors: $num_sels\";\n\n                my @idxs;\n                for (1 .. $num_sels) {\n                    my $i = 0;\n                    while (read_bit($fh, \\$buffer)) {\n                        $i += 1;\n                        ($i < $num_trees) or die \"error\";\n                    }\n                    push @idxs, $i;\n                }\n\n                my $sels = mtf_decode(\\@idxs, [0 .. $num_trees - 1]);\n                say STDERR \"Selectors: (@$sels)\";\n\n                my $MaxHuffmanBits = 20;\n                my $num_syms       = scalar(@alphabet) + 2;\n\n                my @trees;\n                for (1 .. $num_trees) {\n                    my @clens;\n                    my $clen = bits2int($fh, 5, \\$buffer);\n                    for (1 .. $num_syms) {\n                        while (1) {\n\n                            ($clen > 0 and $clen <= $MaxHuffmanBits)\n                              or warn \"Invalid code length: $clen!\\n\";\n\n                            if (not read_bit($fh, \\$buffer)) {\n                                last;\n                            }\n\n                            $clen -= read_bit($fh, \\$buffer) ? 1 : -1;\n                        }\n\n                        push @clens, $clen;\n                    }\n                    push @trees, \\@clens;\n                    say STDERR \"Code lengths: (@clens)\";\n                }\n\n                foreach my $tree (@trees) {\n                    my $maxLen = max(@$tree);\n                    my $sum    = 1 << $maxLen;\n                    for my $clen (@$tree) {\n                        $sum -= (1 << $maxLen) >> $clen;\n                    }\n\n                    $sum == 0 or warn \"incomplete tree detected: (@$tree)\\n\";\n                }\n\n                my @huffman_trees = map { (huffman_from_code_lengths($_))[1] } @trees;\n\n                my $eob = @alphabet + 1;\n\n                my @zrle;\n                my $code = '';\n\n                my $sel_idx = 0;\n                my $tree    = $huffman_trees[$sels->[$sel_idx]];\n                my $decoded = 50;\n\n                while (!eof($fh)) {\n                    $code .= read_bit($fh, \\$buffer);\n\n                    if (length($code) > $MaxHuffmanBits) {\n                        die \"[!] Something went wrong: length of LL code `$code` is > $MaxHuffmanBits.\\n\";\n                    }\n\n                    if (exists($tree->{$code})) {\n\n                        my $sym = $tree->{$code};\n\n                        if ($sym == $eob) {    # end of block marker\n                            say STDERR \"EOB detected: $sym\";\n                            last;\n                        }\n\n                        push @zrle, $sym;\n                        $code = '';\n\n                        if (--$decoded <= 0) {\n                            if (++$sel_idx <= $#$sels) {\n                                $tree = $huffman_trees[$sels->[$sel_idx]];\n                            }\n                            else {\n                                die \"No more selectors\";    # should not happen\n                            }\n                            $decoded = 50;\n                        }\n                    }\n                }\n\n                ##say STDERR \"ZRLE: (@zrle)\";\n                my @mtf = reverse @{zrle_decode([reverse @zrle])};\n                ##say STDERR \"MTF: (@mtf)\";\n\n                my $bwt = symbols2string mtf_decode(\\@mtf, \\@alphabet);\n                ## say \"BWT: ($bwt, $bwt_idx)\";\n\n                my $rle4 = string2symbols bwt_decode($bwt, $bwt_idx);\n                my $data = rle4_decode($rle4);\n                my $dec  = symbols2string($data);\n\n                my $new_crc32 = oct('0b' . int2bits_lsb(crc32(pack('b*', unpack('B*', $dec))), 32));\n\n                say STDERR \"Computed CRC32: $new_crc32\";\n\n                if ($crc32 != $new_crc32) {\n                    warn \"CRC32 error: $crc32 (stored) != $new_crc32 (actual)\\n\";\n                }\n\n                $stream_crc32 = ($new_crc32 ^ (0xffffffff & ((0xffffffff & ($stream_crc32 << 1)) | (($stream_crc32 >> 31) & 0x1)))) & 0xffffffff;\n\n                print $out_fh $dec;\n            }\n            elsif ($block_magic eq \"\\27rE8P\\x90\") {    # BlockFooter\n                say STDERR \"Block footer detected\";\n                my $stored_stream_crc32 = bits2int($fh, 32, \\$buffer);\n                say STDERR \"Stream CRC32: $stored_stream_crc32\";\n\n                if ($stream_crc32 != $stored_stream_crc32) {\n                    warn \"Stream CRC32 error: $stored_stream_crc32 (stored) != $stream_crc32 (actual)\\n\";\n                }\n\n                $buffer = '';\n                last;\n            }\n            else {\n                die \"Unknown block magic: $block_magic\";\n            }\n\n        }\n\n        say STDERR \"End of container\";\n    }\n\n    say STDERR \"End of input\";\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        open my $in_fh, '<:raw', $input\n          or die \"Can't open file <<$input>> for reading: $!\";\n\n        open my $out_fh, '>:raw', $output\n          or die \"Can't open file <<$output>> for writing: $!\";\n\n        my_bzip2_decompress($in_fh, $out_fh)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n\n        open my $in_fh, '<:raw', $input\n          or die \"Can't open file <<$input>> for reading: $!\";\n\n        open my $out_fh, '>:raw', $output\n          or die \"Can't open file <<$output>> for writing: $!\";\n\n        my_bzip2_compress($in_fh, $out_fh)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/compress.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 05 May 2023\n# https://github.com/trizen\n\n# A basic implementation of the UNIX `compress` tool, creating a .Z compressed file, using LZW compression.\n\n# This implementation reads from STDIN and outputs to STDOUT:\n#   perl compress.pl < input.txt > output.Z\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 4 - The Unix 'compress' Program\n#   https://youtube.com/watch?v=1cJL9Va80Pk\n\n# See also:\n#   https://en.wikipedia.org/wiki/Lempel%E2%80%93Ziv%E2%80%93Welch\n\nuse 5.036;\n\nuse constant {\n              BUFFER_SIZE     => 8 * 512,          # must be a multiple of 8\n              MAGIC_SIGNATURE => \"\\x1f\\x9d\\x90\",\n             };\n\nsub compress ($in_fh, $out_fh) {\n\n    binmode($in_fh,  ':raw');\n    binmode($out_fh, ':raw');\n\n    print {$out_fh} MAGIC_SIGNATURE;\n\n    my $dict_size  = 256;\n    my %dictionary = (map { (chr($_), $_) } 0 .. $dict_size - 1);\n\n    ++$dict_size;    # 256 is the 'RESET' marker\n\n    my $num_bits = 9;\n    my $max_bits = 16;\n\n    my $max_bits_size = (1 << $num_bits);\n    my $max_dict_size = (1 << $max_bits);\n\n    my $bitstream      = '';\n    my $bitstream_size = 0;\n\n    my sub output_index ($symbol) {\n\n        $bitstream .= reverse(sprintf('%0*b', $num_bits, $dictionary{$symbol}));\n        $bitstream_size += $num_bits;\n\n        if ($bitstream_size % BUFFER_SIZE == 0) {\n            print {$out_fh} pack(\"b*\", $bitstream);\n            $bitstream      = '';\n            $bitstream_size = 0;\n        }\n    }\n\n    my $w = '';\n\n    while (defined(my $c = getc($in_fh))) {\n        my $wc = $w . $c;\n        if (exists($dictionary{$wc})) {\n            $w = $wc;\n        }\n        else {\n            output_index($w);\n            if ($dict_size < $max_dict_size) {\n                $dictionary{$wc} = $dict_size++;\n                if ($dict_size > $max_bits_size) {\n                    ++$num_bits;\n                    $max_bits_size <<= 1;\n                }\n            }\n            $w = $c;\n        }\n    }\n\n    if ($w ne '') {\n        output_index($w);\n    }\n\n    if ($bitstream ne '') {\n        print {$out_fh} pack('b*', $bitstream);\n    }\n\n    return 1;\n}\n\ncompress(\\*STDIN, \\*STDOUT);\n"
  },
  {
    "path": "Compression/gzip2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 05 May 2024\n# Edit: 06 November 2024\n# https://github.com/trizen\n\n# A valid Gzip file compressor/decompressor, generating DEFLATE blocks of type 0, 1 or 2, whichever is smaller.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\nuse List::Util        qw(all min max);\nuse Getopt::Std       qw(getopts);\n\nuse constant {\n              FORMAT     => 'gz',\n              CHUNK_SIZE => (1 << 15) - 1,\n             };\n\nlocal $Compression::Util::LZ_MIN_LEN       = 4;                # minimum match length in LZ parsing\nlocal $Compression::Util::LZ_MAX_LEN       = 258;              # maximum match length in LZ parsing\nlocal $Compression::Util::LZ_MAX_DIST      = (1 << 15) - 1;    # maximum allowed back-reference distance in LZ parsing\nlocal $Compression::Util::LZ_MAX_CHAIN_LEN = 64;               # how many recent positions to remember in LZ parsing\n\nlocal $Compression::Util::VERBOSE = 1;\n\nmy $MAGIC  = pack('C*', 0x1f, 0x8b);                           # magic MIME type\nmy $CM     = chr(0x08);                                        # 0x08 = DEFLATE\nmy $FLAGS  = chr(0x00);                                        # flags\nmy $MTIME  = pack('C*', (0x00) x 4);                           # modification time\nmy $XFLAGS = chr(0x00);                                        # extra flags\nmy $OS     = chr(0x03);                                        # 0x03 = Unix\n\nmy ($DISTANCE_SYMBOLS, $LENGTH_SYMBOLS, $LENGTH_INDICES) = make_deflate_tables();\n\nsub usage ($code = 0) {\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\n#################\n# GZIP COMPRESSOR\n#################\n\nsub my_gzip_compress ($in_fh, $out_fh) {\n\n    print $out_fh $MAGIC, $CM, $FLAGS, $MTIME, $XFLAGS, $OS;\n\n    my $total_length = 0;\n    my $crc32        = 0;\n\n    my $bitstring = '';\n\n    if (eof($in_fh)) {    # empty file\n        $bitstring = '1' . '10' . '0000000';\n    }\n\n    while (read($in_fh, (my $chunk), CHUNK_SIZE)) {\n\n        $crc32 = crc32($chunk, $crc32);\n        $total_length += length($chunk);\n\n        my ($literals, $distances, $lengths) = lzss_encode($chunk);\n\n        $bitstring .= eof($in_fh) ? '1' : '0';\n\n        my $bt1_bitstring = deflate_create_block_type_1($literals, $distances, $lengths);\n\n        # When block type 1 is larger than the input, then we have random uncompressible data: use block type 0\n        if ((length($bt1_bitstring) >> 3) > length($chunk) + 5) {\n\n            say STDERR \":: Using block type: 0\";\n\n            $bitstring .= '00';\n\n            print $out_fh pack('b*', $bitstring);                                   # pads to a byte\n            print $out_fh pack('b*', deflate_create_block_type_0_header($chunk));\n            print $out_fh $chunk;\n\n            $bitstring = '';\n            next;\n        }\n\n        my $bt2_bitstring = deflate_create_block_type_2($literals, $distances, $lengths);\n\n        # When block type 2 is larger than block type 1, then we may have very small data\n        if (length($bt2_bitstring) > length($bt1_bitstring)) {\n            say STDERR \":: Using block type: 1\";\n            $bitstring .= $bt1_bitstring;\n        }\n        else {\n            say STDERR \":: Using block type: 2\";\n            $bitstring .= $bt2_bitstring;\n        }\n\n        print $out_fh pack('b*', substr($bitstring, 0, length($bitstring) - (length($bitstring) % 8), ''));\n    }\n\n    if ($bitstring ne '') {\n        print $out_fh pack('b*', $bitstring);\n    }\n\n    print $out_fh pack('b*', int2bits_lsb($crc32,        32));\n    print $out_fh pack('b*', int2bits_lsb($total_length, 32));\n\n    return 1;\n}\n\n###################\n# GZIP DECOMPRESSOR\n###################\n\nsub my_gzip_decompress ($in_fh, $out_fh) {\n\n    my $MAGIC = (getc($in_fh) // die \"error\") . (getc($in_fh) // die \"error\");\n\n    if ($MAGIC ne pack('C*', 0x1f, 0x8b)) {\n        die \"Not a valid Gzip container!\\n\";\n    }\n\n    my $CM     = getc($in_fh) // die \"error\";                             # 0x08 = DEFLATE\n    my $FLAGS  = ord(getc($in_fh) // die \"error\");                        # flags\n    my $MTIME  = join('', map { getc($in_fh) // die \"error\" } 1 .. 4);    # modification time\n    my $XFLAGS = getc($in_fh) // die \"error\";                             # extra flags\n    my $OS     = getc($in_fh) // die \"error\";                             # 0x03 = Unix\n\n    if ($CM ne chr(0x08)) {\n        die \"Only DEFLATE compression method is supported (0x08)! Got: 0x\", sprintf('%02x', ord($CM));\n    }\n\n    # Reference:\n    #   https://web.archive.org/web/20240221024029/https://forensics.wiki/gzip/\n\n    my $has_filename        = 0;\n    my $has_comment         = 0;\n    my $has_header_checksum = 0;\n    my $has_extra_fields    = 0;\n\n    if ($FLAGS & 0x08) {\n        $has_filename = 1;\n    }\n\n    if ($FLAGS & 0x10) {\n        $has_comment = 1;\n    }\n\n    if ($FLAGS & 0x02) {\n        $has_header_checksum = 1;\n    }\n\n    if ($FLAGS & 0x04) {\n        $has_extra_fields = 1;\n    }\n\n    if ($has_extra_fields) {\n        my $size = bytes2int_lsb($in_fh, 2);\n        read($in_fh, (my $extra_field_data), $size) // die \"can't read extra field data: $!\";\n        say STDERR \":: Extra field data: $extra_field_data\";\n    }\n\n    if ($has_filename) {\n        my $filename = read_null_terminated($in_fh);    # filename\n        say STDERR \":: Filename: $filename\";\n    }\n\n    if ($has_comment) {\n        my $comment = read_null_terminated($in_fh);     # comment\n        say STDERR \":: Comment: $comment\";\n    }\n\n    if ($has_header_checksum) {\n        my $header_checksum = bytes2int_lsb($in_fh, 2);\n        say STDERR \":: Header checksum: $header_checksum\";\n    }\n\n    my $crc32         = 0;\n    my $actual_length = 0;\n    my $buffer        = '';\n    my $search_window = '';\n\n    while (1) {\n\n        my $is_last = read_bit_lsb($in_fh, \\$buffer);\n        my $chunk   = deflate_extract_next_block($in_fh, \\$buffer, \\$search_window);\n\n        print $out_fh $chunk;\n        $crc32 = crc32($chunk, $crc32);\n        $actual_length += length($chunk);\n\n        last if $is_last;\n    }\n\n    $buffer = '';    # discard any padding bits\n\n    my $stored_crc32 = bits2int_lsb($in_fh, 32, \\$buffer);\n    my $actual_crc32 = $crc32;\n\n    say STDERR '';\n\n    if ($stored_crc32 != $actual_crc32) {\n        print STDERR \"[!] The CRC32 does not match: $actual_crc32 (actual) != $stored_crc32 (stored)\\n\";\n    }\n    else {\n        print STDERR \":: CRC32 value: $actual_crc32\\n\";\n    }\n\n    my $stored_length = bits2int_lsb($in_fh, 32, \\$buffer);\n\n    if ($stored_length != $actual_length) {\n        print STDERR \"[!] The length does not match: $actual_length (actual) != $stored_length (stored)\\n\";\n    }\n    else {\n        print STDERR \":: Total length: $actual_length\\n\";\n    }\n\n    if (eof($in_fh)) {\n        print STDERR \"\\n:: Reached the end of the file.\\n\";\n    }\n    else {\n        print STDERR \"\\n:: There is something else in the container! Trying to recurse!\\n\\n\";\n        __SUB__->($in_fh, $out_fh);\n    }\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        open my $in_fh, '<:raw', $input\n          or die \"Can't open file <<$input>> for reading: $!\";\n\n        open my $out_fh, '>:raw', $output\n          or die \"Can't open file <<$output>> for writing: $!\";\n\n        my_gzip_decompress($in_fh, $out_fh)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n\n        open my $in_fh, '<:raw', $input\n          or die \"Can't open file <<$input>> for reading: $!\";\n\n        open my $out_fh, '>:raw', $output\n          or die \"Can't open file <<$output>> for writing: $!\";\n\n        my_gzip_compress($in_fh, $out_fh)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/gzip_block_type_1.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 13 January 2024\n# Edit: 05 April 2024\n# https://github.com/trizen\n\n# Create a valid Gzip container, using DEFLATE's Block Type 1: LZSS + fixed-length prefix codes.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {CHUNK_SIZE => (1 << 18) - 1,};\n\nlocal $Compression::Util::LZ_MIN_LEN       = 4;                # minimum match length in LZ parsing\nlocal $Compression::Util::LZ_MAX_LEN       = 258;              # maximum match length in LZ parsing\nlocal $Compression::Util::LZ_MAX_DIST      = (1 << 15) - 1;    # maximum allowed back-reference distance in LZ parsing\nlocal $Compression::Util::LZ_MAX_CHAIN_LEN = 64;               # how many recent positions to remember in LZ parsing\n\nmy $MAGIC  = pack('C*', 0x1f, 0x8b);                           # magic MIME type\nmy $CM     = chr(0x08);                                        # 0x08 = DEFLATE\nmy $FLAGS  = chr(0x00);                                        # flags\nmy $MTIME  = pack('C*', (0x00) x 4);                           # modification time\nmy $XFLAGS = chr(0x00);                                        # extra flags\nmy $OS     = chr(0x03);                                        # 0x03 = Unix\n\nmy $input  = $ARGV[0] // die \"usage: $0 [input] [output.gz]\\n\";\nmy $output = $ARGV[1] // (basename($input) . '.gz');\n\nopen my $in_fh, '<:raw', $input\n  or die \"Can't open file <<$input>> for reading: $!\";\n\nopen my $out_fh, '>:raw', $output\n  or die \"Can't open file <<$output>> for writing: $!\";\n\nprint $out_fh $MAGIC, $CM, $FLAGS, $MTIME, $XFLAGS, $OS;\n\nmy $total_length = 0;\nmy $crc32        = 0;\n\nmy $bitstring  = '';\nmy $block_type = '10';    # 00 = store; 10 = LZSS + Fixed codes; 01 = LZSS + Dynamic codes\n\nmy @code_lengths = (0) x 288;\nforeach my $i (0 .. 143) {\n    $code_lengths[$i] = 8;\n}\nforeach my $i (144 .. 255) {\n    $code_lengths[$i] = 9;\n}\nforeach my $i (256 .. 279) {\n    $code_lengths[$i] = 7;\n}\nforeach my $i (280 .. 287) {\n    $code_lengths[$i] = 8;\n}\n\nmy ($dict)      = huffman_from_code_lengths(\\@code_lengths);\nmy ($dist_dict) = huffman_from_code_lengths([(5) x 32]);\n\nmy ($DISTANCE_SYMBOLS, $LENGTH_SYMBOLS, $LENGTH_INDICES) = make_deflate_tables();\n\nif (eof($in_fh)) {    # empty file\n    $bitstring = '1' . '10' . $dict->{256};\n}\n\nwhile (read($in_fh, (my $chunk), CHUNK_SIZE)) {\n\n    my $chunk_len    = length($chunk);\n    my $is_last      = eof($in_fh) ? '1' : '0';\n    my $block_header = join('', $is_last, $block_type);\n\n    $bitstring .= $block_header;\n    my ($literals, $indices, $lengths) = lzss_encode($chunk);\n\n    foreach my $k (0 .. $#$literals) {\n\n        if ($lengths->[$k] == 0) {\n            $bitstring .= $dict->{$literals->[$k]};\n            next;\n        }\n\n        my $len  = $lengths->[$k];\n        my $dist = $indices->[$k];\n\n        {\n            my $len_idx = $LENGTH_INDICES->[$len];\n            my ($min, $bits) = @{$LENGTH_SYMBOLS->[$len_idx]};\n\n            $bitstring .= $dict->{$len_idx + 256 - 1};\n            $bitstring .= int2bits_lsb($len - $min, $bits) if ($bits > 0);\n        }\n\n        {\n            my $dist_idx = find_deflate_index($dist, $DISTANCE_SYMBOLS);\n            my ($min, $bits) = @{$DISTANCE_SYMBOLS->[$dist_idx]};\n\n            $bitstring .= $dist_dict->{$dist_idx - 1};\n            $bitstring .= int2bits_lsb($dist - $min, $bits) if ($bits > 0);\n        }\n    }\n\n    $bitstring .= $dict->{256};    # end-of-block symbol\n\n    my $bits_len = length($bitstring);\n    print $out_fh pack('b*', substr($bitstring, 0, $bits_len - ($bits_len % 8), ''));\n\n    $crc32 = crc32($chunk, $crc32);\n    $total_length += $chunk_len;\n}\n\nif ($bitstring ne '') {\n    print $out_fh pack('b*', $bitstring);\n}\n\nprint $out_fh pack('b*', int2bits_lsb($crc32,        32));\nprint $out_fh pack('b*', int2bits_lsb($total_length, 32));\n\nclose $in_fh;\nclose $out_fh;\n"
  },
  {
    "path": "Compression/gzip_block_type_1_huffman_only.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 13 January 2024\n# Edit: 05 April 2024\n# https://github.com/trizen\n\n# Create a valid Gzip container, using DEFLATE's Block Type 1 with fixed-length prefix codes only, without LZSS.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\n\nuse constant {\n              CHUNK_SIZE => 0xffff,    # 2^16 - 1\n             };\n\nmy $MAGIC  = pack('C*', 0x1f, 0x8b);    # magic MIME type\nmy $CM     = chr(0x08);                 # 0x08 = DEFLATE\nmy $FLAGS  = chr(0x00);                 # flags\nmy $MTIME  = pack('C*', (0x00) x 4);    # modification time\nmy $XFLAGS = chr(0x00);                 # extra flags\nmy $OS     = chr(0x03);                 # 0x03 = Unix\n\nmy $input  = $ARGV[0] // die \"usage: $0 [input] [output.gz]\\n\";\nmy $output = $ARGV[1] // (basename($input) . '.gz');\n\nopen my $in_fh, '<:raw', $input\n  or die \"Can't open file <<$input>> for reading: $!\";\n\nopen my $out_fh, '>:raw', $output\n  or die \"Can't open file <<$output>> for writing: $!\";\n\nprint $out_fh $MAGIC, $CM, $FLAGS, $MTIME, $XFLAGS, $OS;\n\nmy $total_length = 0;\nmy $crc32        = 0;\n\nmy $bitstring  = '';\nmy $block_type = '10';    # 00 = store; 10 = LZSS + Fixed codes; 01 = LZSS + Dynamic codes\n\nmy @code_lengths = (0) x 288;\nforeach my $i (0 .. 143) {\n    $code_lengths[$i] = 8;\n}\nforeach my $i (144 .. 255) {\n    $code_lengths[$i] = 9;\n}\nforeach my $i (256 .. 279) {\n    $code_lengths[$i] = 7;\n}\nforeach my $i (280 .. 287) {\n    $code_lengths[$i] = 8;\n}\n\nmy ($dict) = huffman_from_code_lengths(\\@code_lengths);\n\nif (eof($in_fh)) {    # empty file\n    $bitstring = '1' . '10' . $dict->{256};\n}\n\nwhile (read($in_fh, (my $chunk), CHUNK_SIZE)) {\n\n    my $chunk_len    = length($chunk);\n    my $is_last      = eof($in_fh) ? '1' : '0';\n    my $block_header = join('', $is_last, $block_type);\n\n    $bitstring .= $block_header;\n    $bitstring .= huffman_encode([unpack('C*', $chunk), 256], $dict);\n\n    print $out_fh pack('b*', substr($bitstring, 0, length($bitstring) - (length($bitstring) % 8), ''));\n\n    $crc32 = crc32($chunk, $crc32);\n    $total_length += $chunk_len;\n}\n\nif ($bitstring ne '') {\n    print $out_fh pack('b*', $bitstring);\n}\n\nprint $out_fh pack('b*', int2bits_lsb($crc32,        32));\nprint $out_fh pack('b*', int2bits_lsb($total_length, 32));\n\nclose $in_fh;\nclose $out_fh;\n"
  },
  {
    "path": "Compression/gzip_block_type_2.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 13 January 2024\n# Edit: 11 April 2024\n# https://github.com/trizen\n\n# Create a valid Gzip container, using DEFLATE's Block Type 2: LZSS + dynamic prefix codes.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\nuse List::Util        qw(all min max);\n\nuse constant {CHUNK_SIZE => (1 << 15) - 1,};\n\nlocal $Compression::Util::LZ_MIN_LEN       = 4;                # minimum match length in LZ parsing\nlocal $Compression::Util::LZ_MAX_LEN       = 258;              # maximum match length in LZ parsing\nlocal $Compression::Util::LZ_MAX_DIST      = (1 << 15) - 1;    # maximum allowed back-reference distance in LZ parsing\nlocal $Compression::Util::LZ_MAX_CHAIN_LEN = 64;               # how many recent positions to remember in LZ parsing\n\nmy $MAGIC  = pack('C*', 0x1f, 0x8b);                           # magic MIME type\nmy $CM     = chr(0x08);                                        # 0x08 = DEFLATE\nmy $FLAGS  = chr(0x00);                                        # flags\nmy $MTIME  = pack('C*', (0x00) x 4);                           # modification time\nmy $XFLAGS = chr(0x00);                                        # extra flags\nmy $OS     = chr(0x03);                                        # 0x03 = Unix\n\nmy $input  = $ARGV[0] // die \"usage: $0 [input] [output.gz]\\n\";\nmy $output = $ARGV[1] // (basename($input) . '.gz');\n\nsub code_length_encoding ($dict) {\n\n    my @lengths;\n\n    foreach my $symbol (0 .. max(keys %$dict) // 0) {\n        if (exists($dict->{$symbol})) {\n            push @lengths, length($dict->{$symbol});\n        }\n        else {\n            push @lengths, 0;\n        }\n    }\n\n    my $size        = scalar(@lengths);\n    my $rl          = run_length(\\@lengths);\n    my $offset_bits = '';\n\n    my @CL_symbols;\n\n    foreach my $pair (@$rl) {\n        my ($v, $run) = @$pair;\n\n        while ($v == 0 and $run >= 3) {\n\n            if ($run >= 11) {\n                push @CL_symbols, 18;\n                $run -= 11;\n                $offset_bits .= int2bits_lsb(min($run, 127), 7);\n                $run -= 127;\n            }\n\n            if ($run >= 3 and $run < 11) {\n                push @CL_symbols, 17;\n                $run -= 3;\n                $offset_bits .= int2bits_lsb(min($run, 7), 3);\n                $run -= 7;\n            }\n        }\n\n        if ($v == 0) {\n            push(@CL_symbols, (0) x $run) if ($run > 0);\n            next;\n        }\n\n        push @CL_symbols, $v;\n        $run -= 1;\n\n        while ($run >= 3) {\n            push @CL_symbols, 16;\n            $run -= 3;\n            $offset_bits .= int2bits_lsb(min($run, 3), 2);\n            $run -= 3;\n        }\n\n        push(@CL_symbols, ($v) x $run) if ($run > 0);\n    }\n\n    return (\\@CL_symbols, $size, $offset_bits);\n}\n\nsub cl_encoded_bitstring ($cl_dict, $cl_symbols, $offset_bits) {\n\n    my $bitstring = '';\n    foreach my $cl_symbol (@$cl_symbols) {\n        $bitstring .= $cl_dict->{$cl_symbol};\n        if ($cl_symbol == 16) {\n            $bitstring .= substr($offset_bits, 0, 2, '');\n        }\n        elsif ($cl_symbol == 17) {\n            $bitstring .= substr($offset_bits, 0, 3, '');\n        }\n        elsif ($cl_symbol == 18) {\n            $bitstring .= substr($offset_bits, 0, 7, '');\n        }\n    }\n\n    return $bitstring;\n}\n\nsub create_cl_dictionary (@cl_symbols) {\n\n    my @keys;\n    my $freq = frequencies(\\@cl_symbols);\n\n    while (1) {\n        my ($cl_dict) = huffman_from_freq($freq);\n\n        # The CL codes must have at most 7 bits\n        return $cl_dict if all { length($_) <= 7 } values %$cl_dict;\n\n        if (scalar(@keys) == 0) {\n            @keys = sort { $freq->{$b} <=> $freq->{$a} } keys %$freq;\n        }\n\n        # Scale down the frequencies and try again\n        foreach my $k (@keys) {\n            if ($freq->{$k} > 1) {\n                $freq->{$k} >>= 1;\n            }\n            else {\n                last;\n            }\n        }\n    }\n}\n\nopen my $in_fh, '<:raw', $input\n  or die \"Can't open file <<$input>> for reading: $!\";\n\nopen my $out_fh, '>:raw', $output\n  or die \"Can't open file <<$output>> for writing: $!\";\n\nprint $out_fh $MAGIC, $CM, $FLAGS, $MTIME, $XFLAGS, $OS;\n\nmy $total_length = 0;\nmy $crc32        = 0;\n\nmy $bitstring  = '';\nmy $block_type = '01';                                                                 # 00 = store; 10 = LZSS + Fixed codes; 01 = LZSS + Dynamic codes\nmy @CL_order   = (16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15);\n\nmy ($DISTANCE_SYMBOLS, $LENGTH_SYMBOLS, $LENGTH_INDICES) = make_deflate_tables();\n\nif (eof($in_fh)) {    # empty file\n    $bitstring = '1' . '10' . '0000000';\n}\n\nwhile (read($in_fh, (my $chunk), CHUNK_SIZE)) {\n\n    my $chunk_len    = length($chunk);\n    my $is_last      = eof($in_fh) ? '1' : '0';\n    my $block_header = join('', $is_last, $block_type);\n\n    my ($literals, $distances, $lengths) = lzss_encode($chunk);\n\n    my @len_symbols;\n    my @dist_symbols;\n    my $offset_bits = '';\n\n    foreach my $k (0 .. $#$literals) {\n\n        if ($lengths->[$k] == 0) {\n            push @len_symbols, $literals->[$k];\n            next;\n        }\n\n        my $len  = $lengths->[$k];\n        my $dist = $distances->[$k];\n\n        {\n            my $len_idx = $LENGTH_INDICES->[$len];\n            my ($min, $bits) = @{$LENGTH_SYMBOLS->[$len_idx]};\n\n            push @len_symbols, [$len_idx + 256 - 1, $bits];\n            $offset_bits .= int2bits_lsb($len - $min, $bits) if ($bits > 0);\n        }\n\n        {\n            my $dist_idx = find_deflate_index($dist, $DISTANCE_SYMBOLS);\n            my ($min, $bits) = @{$DISTANCE_SYMBOLS->[$dist_idx]};\n\n            push @dist_symbols, [$dist_idx - 1, $bits];\n            $offset_bits .= int2bits_lsb($dist - $min, $bits) if ($bits > 0);\n        }\n    }\n\n    push @len_symbols, 256;    # end-of-block marker\n\n    my ($dict)      = huffman_from_symbols([map { ref($_) eq 'ARRAY' ? $_->[0] : $_ } @len_symbols]);\n    my ($dist_dict) = huffman_from_symbols([map { $_->[0] } @dist_symbols]);\n\n    my ($LL_code_lengths,       $LL_cl_len,       $LL_offset_bits)       = code_length_encoding($dict);\n    my ($distance_code_lengths, $distance_cl_len, $distance_offset_bits) = code_length_encoding($dist_dict);\n\n    my $cl_dict = create_cl_dictionary(@$LL_code_lengths, @$distance_code_lengths);\n\n    my @CL_code_lenghts;\n    foreach my $symbol (0 .. 18) {\n        if (exists($cl_dict->{$symbol})) {\n            push @CL_code_lenghts, length($cl_dict->{$symbol});\n        }\n        else {\n            push @CL_code_lenghts, 0;\n        }\n    }\n\n    # Put the CL codes in the required order\n    @CL_code_lenghts = @CL_code_lenghts[@CL_order];\n\n    while (scalar(@CL_code_lenghts) > 4 and $CL_code_lenghts[-1] == 0) {\n        pop @CL_code_lenghts;\n    }\n\n    my $CL_code_lengths_bitstring = join('', map { int2bits_lsb($_, 3) } @CL_code_lenghts);\n\n    my $LL_code_lengths_bitstring       = cl_encoded_bitstring($cl_dict, $LL_code_lengths,       $LL_offset_bits);\n    my $distance_code_lengths_bitstring = cl_encoded_bitstring($cl_dict, $distance_code_lengths, $distance_offset_bits);\n\n    # (5 bits) HLIT = (number of LL code entries present) - 257\n    my $HLIT = $LL_cl_len - 257;\n\n    # (5 bits) HDIST = (number of distance code entries present) - 1\n    my $HDIST = $distance_cl_len - 1;\n\n    # (4 bits) HCLEN = (number of CL code entries present) - 4\n    my $HCLEN = scalar(@CL_code_lenghts) - 4;\n\n    $block_header .= int2bits_lsb($HLIT,  5);\n    $block_header .= int2bits_lsb($HDIST, 5);\n    $block_header .= int2bits_lsb($HCLEN, 4);\n\n    $block_header .= $CL_code_lengths_bitstring;\n    $block_header .= $LL_code_lengths_bitstring;\n    $block_header .= $distance_code_lengths_bitstring;\n\n    $bitstring .= $block_header;\n\n    foreach my $symbol (@len_symbols) {\n        if (ref($symbol) eq 'ARRAY') {\n\n            my ($len, $len_offset) = @$symbol;\n            $bitstring .= $dict->{$len};\n            $bitstring .= substr($offset_bits, 0, $len_offset, '') if ($len_offset > 0);\n\n            my ($dist, $dist_offset) = @{shift(@dist_symbols)};\n            $bitstring .= $dist_dict->{$dist};\n            $bitstring .= substr($offset_bits, 0, $dist_offset, '') if ($dist_offset > 0);\n        }\n        else {\n            $bitstring .= $dict->{$symbol};\n        }\n    }\n\n    print $out_fh pack('b*', substr($bitstring, 0, length($bitstring) - (length($bitstring) % 8), ''));\n\n    $crc32 = crc32($chunk, $crc32);\n    $total_length += $chunk_len;\n}\n\nif ($bitstring ne '') {\n    print $out_fh pack('b*', $bitstring);\n}\n\nprint $out_fh pack('b*', int2bits_lsb($crc32,        32));\nprint $out_fh pack('b*', int2bits_lsb($total_length, 32));\n\nclose $in_fh;\nclose $out_fh;\n"
  },
  {
    "path": "Compression/gzip_block_type_2_huffman_only.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 13 January 2024\n# Edit: 09 April 2024\n# https://github.com/trizen\n\n# Create a valid Gzip container, using DEFLATE's Block Type 2 with dynamic prefix codes only, without LZSS.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\nuse List::Util        qw(uniq);\n\nuse constant {\n              CHUNK_SIZE => (1 << 15) - 1,    # 2^15 - 1\n             };\n\nmy $MAGIC  = pack('C*', 0x1f, 0x8b);    # magic MIME type\nmy $CM     = chr(0x08);                 # 0x08 = DEFLATE\nmy $FLAGS  = chr(0x00);                 # flags\nmy $MTIME  = pack('C*', (0x00) x 4);    # modification time\nmy $XFLAGS = chr(0x00);                 # extra flags\nmy $OS     = chr(0x03);                 # 0x03 = Unix\n\nmy $input  = $ARGV[0] // die \"usage: $0 [input] [output.gz]\\n\";\nmy $output = $ARGV[1] // (basename($input) . '.gz');\n\nopen my $in_fh, '<:raw', $input\n  or die \"Can't open file <<$input>> for reading: $!\";\n\nopen my $out_fh, '>:raw', $output\n  or die \"Can't open file <<$output>> for writing: $!\";\n\nprint $out_fh $MAGIC, $CM, $FLAGS, $MTIME, $XFLAGS, $OS;\n\nmy $total_length = 0;\nmy $crc32        = 0;\n\nmy $bitstring  = '';\nmy $block_type = '01';                                                                 # 00 = store; 10 = LZSS + Fixed codes; 01 = LZSS + Dynamic codes\nmy @CL_order   = (16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15);\n\nif (eof($in_fh)) {    # empty file\n    $bitstring = '1' . '10' . '0000000';\n}\n\nwhile (read($in_fh, (my $chunk), CHUNK_SIZE)) {\n\n    my $chunk_len    = length($chunk);\n    my $is_last      = eof($in_fh) ? '1' : '0';\n    my $block_header = join('', $is_last, $block_type);\n\n    my @symbols = (unpack('C*', $chunk), 256);\n    my ($dict, $rev_dict) = huffman_from_symbols(\\@symbols);\n\n    my @LL_code_lengths;\n    foreach my $symbol (0 .. 285) {\n        if (exists($dict->{$symbol})) {\n            push @LL_code_lengths, length($dict->{$symbol});\n        }\n        else {\n            push @LL_code_lengths, 0;\n        }\n    }\n\n    while (scalar(@LL_code_lengths) > 1 and $LL_code_lengths[-1] == 0) {\n        pop @LL_code_lengths;\n    }\n\n    my @distance_code_lengths;\n    foreach my $symbol (0 .. 29) {\n        push @distance_code_lengths, 0;\n    }\n\n    while (scalar(@distance_code_lengths) > 1 and $distance_code_lengths[-1] == 0) {\n        pop @distance_code_lengths;\n    }\n\n    my @CL_code;\n    foreach my $length (uniq(@LL_code_lengths, @distance_code_lengths)) {\n        push @CL_code, $length;\n    }\n\n    my ($cl_dict) = huffman_from_symbols(\\@CL_code);\n\n    my @CL_code_lenghts;\n    foreach my $symbol (0 .. 18) {\n        if (exists($cl_dict->{$symbol})) {\n            push @CL_code_lenghts, length($cl_dict->{$symbol});\n        }\n        else {\n            push @CL_code_lenghts, 0;\n        }\n    }\n\n    # Put the CL codes in the required order\n    @CL_code_lenghts = @CL_code_lenghts[@CL_order];\n\n    while (scalar(@CL_code_lenghts) > 4 and $CL_code_lenghts[-1] == 0) {\n        pop @CL_code_lenghts;\n    }\n\n    my $CL_code_lengths_bitstring       = join('', map { int2bits_lsb($_, 3) } @CL_code_lenghts);\n    my $LL_code_lengths_bitstring       = join('', map { $cl_dict->{$_} } @LL_code_lengths);\n    my $distance_code_lengths_bitstring = join('', map { $cl_dict->{$_} } @distance_code_lengths);\n\n    # (5 bits) HLIT = (number of LL code entries present) - 257\n    my $HLIT = scalar(@LL_code_lengths) - 257;\n\n    # (5 bits) HDIST = (number of distance code entries present) - 1\n    my $HDIST = scalar(@distance_code_lengths) - 1;\n\n    # (4 bits) HCLEN = (number of CL code entries present) - 4\n    my $HCLEN = scalar(@CL_code_lenghts) - 4;\n\n    $block_header .= int2bits_lsb($HLIT,  5);\n    $block_header .= int2bits_lsb($HDIST, 5);\n    $block_header .= int2bits_lsb($HCLEN, 4);\n\n    $block_header .= $CL_code_lengths_bitstring;\n    $block_header .= $LL_code_lengths_bitstring;\n    $block_header .= $distance_code_lengths_bitstring;\n\n    $bitstring .= $block_header;\n    $bitstring .= huffman_encode(\\@symbols, $dict);\n\n    print $out_fh pack('b*', substr($bitstring, 0, length($bitstring) - (length($bitstring) % 8), ''));\n\n    $crc32 = crc32($chunk, $crc32);\n    $total_length += $chunk_len;\n}\n\nif ($bitstring ne '') {\n    print $out_fh pack('b*', $bitstring);\n}\n\nprint $out_fh pack('b*', int2bits_lsb($crc32,        32));\nprint $out_fh pack('b*', int2bits_lsb($total_length, 32));\n\nclose $in_fh;\nclose $out_fh;\n"
  },
  {
    "path": "Compression/gzip_block_type_2_simple.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 13 January 2024\n# Edit: 09 April 2024\n# https://github.com/trizen\n\n# Create a valid Gzip container, using DEFLATE's Block Type 2: LZSS + dynamic prefix codes.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\nuse List::Util        qw(uniq);\n\nuse constant {CHUNK_SIZE => (1 << 15) - 1,};\n\nlocal $Compression::Util::LZ_MIN_LEN       = 4;                # minimum match length in LZ parsing\nlocal $Compression::Util::LZ_MAX_LEN       = 258;              # maximum match length in LZ parsing\nlocal $Compression::Util::LZ_MAX_DIST      = (1 << 15) - 1;    # maximum allowed back-reference distance in LZ parsing\nlocal $Compression::Util::LZ_MAX_CHAIN_LEN = 64;               # how many recent positions to remember in LZ parsing\n\nmy $MAGIC  = pack('C*', 0x1f, 0x8b);                           # magic MIME type\nmy $CM     = chr(0x08);                                        # 0x08 = DEFLATE\nmy $FLAGS  = chr(0x00);                                        # flags\nmy $MTIME  = pack('C*', (0x00) x 4);                           # modification time\nmy $XFLAGS = chr(0x00);                                        # extra flags\nmy $OS     = chr(0x03);                                        # 0x03 = Unix\n\nmy $input  = $ARGV[0] // die \"usage: $0 [input] [output.gz]\\n\";\nmy $output = $ARGV[1] // (basename($input) . '.gz');\n\nopen my $in_fh, '<:raw', $input\n  or die \"Can't open file <<$input>> for reading: $!\";\n\nopen my $out_fh, '>:raw', $output\n  or die \"Can't open file <<$output>> for writing: $!\";\n\nprint $out_fh $MAGIC, $CM, $FLAGS, $MTIME, $XFLAGS, $OS;\n\nmy $total_length = 0;\nmy $crc32        = 0;\n\nmy $bitstring  = '';\nmy $block_type = '01';                                                                 # 00 = store; 10 = LZSS + Fixed codes; 01 = LZSS + Dynamic codes\nmy @CL_order   = (16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15);\n\nmy ($DISTANCE_SYMBOLS, $LENGTH_SYMBOLS, $LENGTH_INDICES) = make_deflate_tables();\n\nif (eof($in_fh)) {    # empty file\n    $bitstring = '1' . '10' . '0000000';\n}\n\nwhile (read($in_fh, (my $chunk), CHUNK_SIZE)) {\n\n    my $chunk_len    = length($chunk);\n    my $is_last      = eof($in_fh) ? '1' : '0';\n    my $block_header = join('', $is_last, $block_type);\n\n    my ($literals, $distances, $lengths) = lzss_encode($chunk);\n\n    my @len_symbols;\n    my @dist_symbols;\n    my $offset_bits = '';\n\n    foreach my $k (0 .. $#$literals) {\n\n        if ($lengths->[$k] == 0) {\n            push @len_symbols, $literals->[$k];\n            next;\n        }\n\n        my $len  = $lengths->[$k];\n        my $dist = $distances->[$k];\n\n        {\n            my $len_idx = $LENGTH_INDICES->[$len];\n            my ($min, $bits) = @{$LENGTH_SYMBOLS->[$len_idx]};\n\n            push @len_symbols, [$len_idx + 256 - 1, $bits];\n            $offset_bits .= int2bits_lsb($len - $min, $bits) if ($bits > 0);\n        }\n\n        {\n            my $dist_idx = find_deflate_index($dist, $DISTANCE_SYMBOLS);\n            my ($min, $bits) = @{$DISTANCE_SYMBOLS->[$dist_idx]};\n\n            push @dist_symbols, [$dist_idx - 1, $bits];\n            $offset_bits .= int2bits_lsb($dist - $min, $bits) if ($bits > 0);\n        }\n    }\n\n    push @len_symbols, 256;    # end-of-block marker\n\n    my ($dict)      = huffman_from_symbols([map { ref($_) eq 'ARRAY' ? $_->[0] : $_ } @len_symbols]);\n    my ($dist_dict) = huffman_from_symbols([map { $_->[0] } @dist_symbols]);\n\n    my @LL_code_lengths;\n    foreach my $symbol (0 .. 285) {\n        if (exists($dict->{$symbol})) {\n            push @LL_code_lengths, length($dict->{$symbol});\n        }\n        else {\n            push @LL_code_lengths, 0;\n        }\n    }\n\n    while (scalar(@LL_code_lengths) > 1 and $LL_code_lengths[-1] == 0) {\n        pop @LL_code_lengths;\n    }\n\n    my @distance_code_lengths;\n    foreach my $symbol (0 .. 29) {\n        if (exists($dist_dict->{$symbol})) {\n            push @distance_code_lengths, length($dist_dict->{$symbol});\n        }\n        else {\n            push @distance_code_lengths, 0;\n        }\n    }\n\n    while (scalar(@distance_code_lengths) > 1 and $distance_code_lengths[-1] == 0) {\n        pop @distance_code_lengths;\n    }\n\n    my @CL_code = uniq(@LL_code_lengths, @distance_code_lengths);\n    my ($cl_dict) = huffman_from_symbols(\\@CL_code);\n\n    my @CL_code_lenghts;\n    foreach my $symbol (0 .. 18) {\n        if (exists($cl_dict->{$symbol})) {\n            push @CL_code_lenghts, length($cl_dict->{$symbol});\n        }\n        else {\n            push @CL_code_lenghts, 0;\n        }\n    }\n\n    # Put the CL codes in the required order\n    @CL_code_lenghts = @CL_code_lenghts[@CL_order];\n\n    while (scalar(@CL_code_lenghts) > 4 and $CL_code_lenghts[-1] == 0) {\n        pop @CL_code_lenghts;\n    }\n\n    my $CL_code_lengths_bitstring       = join('', map { int2bits_lsb($_, 3) } @CL_code_lenghts);\n    my $LL_code_lengths_bitstring       = join('', @{$cl_dict}{@LL_code_lengths});\n    my $distance_code_lengths_bitstring = join('', @{$cl_dict}{@distance_code_lengths});\n\n    # (5 bits) HLIT = (number of LL code entries present) - 257\n    my $HLIT = scalar(@LL_code_lengths) - 257;\n\n    # (5 bits) HDIST = (number of distance code entries present) - 1\n    my $HDIST = scalar(@distance_code_lengths) - 1;\n\n    # (4 bits) HCLEN = (number of CL code entries present) - 4\n    my $HCLEN = scalar(@CL_code_lenghts) - 4;\n\n    $block_header .= int2bits_lsb($HLIT,  5);\n    $block_header .= int2bits_lsb($HDIST, 5);\n    $block_header .= int2bits_lsb($HCLEN, 4);\n\n    $block_header .= $CL_code_lengths_bitstring;\n    $block_header .= $LL_code_lengths_bitstring;\n    $block_header .= $distance_code_lengths_bitstring;\n\n    $bitstring .= $block_header;\n\n    foreach my $symbol (@len_symbols) {\n        if (ref($symbol) eq 'ARRAY') {\n\n            my ($len, $len_offset) = @$symbol;\n            $bitstring .= $dict->{$len};\n            $bitstring .= substr($offset_bits, 0, $len_offset, '') if ($len_offset > 0);\n\n            my ($dist, $dist_offset) = @{shift(@dist_symbols)};\n            $bitstring .= $dist_dict->{$dist};\n            $bitstring .= substr($offset_bits, 0, $dist_offset, '') if ($dist_offset > 0);\n        }\n        else {\n            $bitstring .= $dict->{$symbol};\n        }\n    }\n\n    print $out_fh pack('b*', substr($bitstring, 0, length($bitstring) - (length($bitstring) % 8), ''));\n\n    $crc32 = crc32($chunk, $crc32);\n    $total_length += $chunk_len;\n}\n\nif ($bitstring ne '') {\n    print $out_fh pack('b*', $bitstring);\n}\n\nprint $out_fh pack('b*', int2bits_lsb($crc32,        32));\nprint $out_fh pack('b*', int2bits_lsb($total_length, 32));\n\nclose $in_fh;\nclose $out_fh;\n"
  },
  {
    "path": "Compression/gzip_comment.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 21 January 2024\n# https://github.com/trizen\n\n# Add and extract a GZIP comment, given a \".gz\" file.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n#\n#   GZIP file format specification version 4.3\n#   https://datatracker.ietf.org/doc/html/rfc1952\n\nuse 5.036;\nuse Getopt::Std  qw(getopts);\nuse MIME::Base64 qw(encode_base64 decode_base64);\n\nuse constant {\n              CHUNK_SIZE => 0xffff,    # 2^16 - 1\n             };\n\ngetopts('ebho:', \\my %opts);\n\nsub usage ($exit_code = 0) {\n    print <<\"EOT\";\nusage: $0 [options] [input.gz] [comment.txt]\"\n\noptions:\n\n    -o  : output file\n    -e  : extract comment\n    -b  : base64 encoding / decoding of the comment\n    -h  : print this message and exit\n\nexample:\n\n    # Add comment to \"input.gz\" from \"file.txt\" (base64-encoded)\n    perl $0 -o output.gz -b input.gz file.txt\n\n    # Extract comment from \"input.gz\" (base64-decoded)\n    perl $0 -o comment.txt -eb input.gz\n\nEOT\n    exit $exit_code;\n}\n\nsub read_null_terminated ($in_fh) {\n    my $string = '';\n    while (1) {\n        my $c = getc($in_fh) // die \"Invalid gzip data\";\n        last if $c eq \"\\0\";\n        $string .= $c;\n    }\n    return $string;\n}\n\nsub extract_comment ($input_gz, $output_file) {\n\n    open my $in_fh, '<:raw', $input_gz\n      or die \"Can't open file <<$input_gz>> for reading: $!\";\n\n    my $MAGIC = (getc($in_fh) // die \"error\") . (getc($in_fh) // die \"error\");\n\n    if ($MAGIC ne pack('C*', 0x1f, 0x8b)) {\n        die \"Not a Gzip file: $input_gz\\n\";\n    }\n\n    my $CM     = getc($in_fh) // die \"error\";                             # 0x08 = DEFLATE\n    my $FLAGS  = getc($in_fh) // die \"error\";                             # flags\n    my $MTIME  = join('', map { getc($in_fh) // die \"error\" } 1 .. 4);    # modification time\n    my $XFLAGS = getc($in_fh) // die \"error\";                             # extra flags\n    my $OS     = getc($in_fh) // die \"error\";                             # 0x03 = Unix\n\n    my $has_filename = 0;\n\n    if ((ord($FLAGS) & 0b0000_1000) != 0) {\n        say STDERR \"Has filename.\";\n        $has_filename = 1;\n    }\n\n    if ((ord($FLAGS) & 0b0001_0000) != 0) {\n        say STDERR \"Has comment.\";\n    }\n    else {\n        die \"No comment was found.\\n\";\n    }\n\n    if ($has_filename) {\n        read_null_terminated($in_fh);    # filename\n    }\n\n    my $comment = read_null_terminated($in_fh);\n\n    my $out_fh;\n    if (defined($output_file)) {\n        open $out_fh, '>:raw', $output_file\n          or die \"Can't open file <<$output_file>> for writing: $!\";\n    }\n    else {\n        $out_fh = \\*STDOUT;\n    }\n\n    if ($opts{b}) {\n        $comment = decode_base64($comment);\n    }\n\n    print $out_fh $comment;\n}\n\nsub add_comment ($input_gz, $comment_file, $output_gz) {\n\n    if (!defined($output_gz)) {\n        if ($input_gz =~ /\\.tar\\.gz\\z/) {\n            $output_gz = \"output.tar.gz\";\n        }\n        elsif ($input_gz =~ /\\.tgz\\z/) {\n            $output_gz = \"output.tgz\";\n        }\n        else {\n            $output_gz = \"output.gz\";\n        }\n    }\n\n    if (-e $output_gz) {\n        die \"Output file <<$output_gz>> already exists!\\n\";\n    }\n\n    open my $in_fh, '<:raw', $input_gz\n      or die \"Can't open file <<$input_gz>> for reading: $!\";\n\n    open my $comment_fh, '<:raw', $comment_file\n      or die \"Can't open file <<$comment_file>> for reading: $!\";\n\n    my $MAGIC = (getc($in_fh) // die \"error\") . (getc($in_fh) // die \"error\");\n\n    if ($MAGIC ne pack('C*', 0x1f, 0x8b)) {\n        die \"Not a Gzip file: $input_gz\\n\";\n    }\n\n    my $CM     = getc($in_fh) // die \"error\";                             # 0x08 = DEFLATE\n    my $FLAGS  = getc($in_fh) // die \"error\";                             # flags\n    my $MTIME  = join('', map { getc($in_fh) // die \"error\" } 1 .. 4);    # modification time\n    my $XFLAGS = getc($in_fh) // die \"error\";                             # extra flags\n    my $OS     = getc($in_fh) // die \"error\";                             # 0x03 = Unix\n\n    open my $out_fh, '>:raw', $output_gz\n      or die \"Can't open file <<$output_gz>> for writing: $!\";\n\n    print $out_fh $MAGIC, $CM, chr(ord($FLAGS) | 0b0001_0000), $MTIME, $XFLAGS, $OS;\n\n    my $has_filename = 0;\n    my $has_comment  = 0;\n\n    if ((ord($FLAGS) & 0b0000_1000) != 0) {\n        say STDERR \"Has filename.\";\n        $has_filename = 1;\n    }\n    else {\n        say STDERR \"Has no filename.\";\n    }\n\n    if ((ord($FLAGS) & 0b0001_0000) != 0) {\n        say STDERR \"Has comment.\";\n        $has_comment = 1;\n    }\n    else {\n        say STDERR \"Has no existing comment.\";\n    }\n\n    if ($has_filename) {\n        my $filename = read_null_terminated($in_fh);    # filename\n        print $out_fh $filename . \"\\0\";\n    }\n\n    if ($has_comment) {\n        say STDERR \"Replacing existing comment.\";\n        read_null_terminated($in_fh);                   # remove existing comment\n    }\n    else {\n        say STDERR \"Adding comment from file.\";\n    }\n\n    my $comment = do {\n        local $/;\n        <$comment_fh>;\n    };\n\n    if ($opts{b}) {\n        $comment = encode_base64($comment);\n    }\n\n    print $out_fh $comment;\n    print $out_fh \"\\0\";\n\n    # Copy the rest of the gzip file\n    while (read($in_fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh $chunk;\n    }\n\n    return 1;\n}\n\nif ($opts{h}) {\n    usage(0);\n}\n\nmy $input_gz = shift(@ARGV) // usage(2);\n\nif ($opts{e}) {\n    extract_comment($input_gz, $opts{o});\n}\nelse {\n    my $comment_file = shift(@ARGV) // usage(2);\n    add_comment($input_gz, $comment_file, $opts{o});\n}\n"
  },
  {
    "path": "Compression/gzip_decompressor.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 13 January 2024\n# Edit: 14 April 2024\n# https://github.com/trizen\n\n# Decompress GZIP files (.gz).\n\n# DEFLATE's block type 0, 1 and 2 are all supported.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\nuse List::Util        qw(max);\nuse Compression::Util qw(:all);\n\nlocal $Compression::Util::LZ_MAX_LEN  = 258;              # maximum match length in LZ parsing\nlocal $Compression::Util::LZ_MAX_DIST = (1 << 15) - 1;    # maximum allowed back-reference distance in LZ parsing\n\nsub extract_block_type_0 ($in_fh, $buffer) {\n\n    my $len           = bits2int_lsb($in_fh, 16, $buffer);\n    my $nlen          = bits2int_lsb($in_fh, 16, $buffer);\n    my $expected_nlen = (~$len) & 0xffff;\n\n    if ($expected_nlen != $nlen) {\n        die \"[!] The ~length value is not correct: $nlen (actual) != $expected_nlen (expected)\\n\";\n    }\n    else {\n        print STDERR \":: Chunk length: $len\\n\";\n    }\n\n    read($in_fh, (my $chunk), $len);\n    return $chunk;\n}\n\nmy ($DISTANCE_SYMBOLS, $LENGTH_SYMBOLS) = make_deflate_tables();\n\nsub decode_huffman($in_fh, $buffer, $rev_dict, $dist_rev_dict, $search_window) {\n\n    my $data = '';\n    my $code = '';\n\n    my $max_ll_code_len   = max(map { length($_) } keys %$rev_dict);\n    my $max_dist_code_len = max(map { length($_) } keys %$dist_rev_dict);\n\n    while (1) {\n        $code .= read_bit_lsb($in_fh, $buffer);\n\n        if (length($code) > $max_ll_code_len) {\n            die \"[!] Something went wrong: length of LL code `$code` is > $max_ll_code_len.\\n\";\n        }\n\n        if (exists($rev_dict->{$code})) {\n\n            my $symbol = $rev_dict->{$code};\n\n            if ($symbol <= 255) {\n                $data           .= chr($symbol);\n                $$search_window .= chr($symbol);\n            }\n            elsif ($symbol == 256) {    # end-of-block marker\n                $code = '';\n                last;\n            }\n            else {                      # LZSS decoding\n                my ($length, $LL_bits) = @{$LENGTH_SYMBOLS->[$symbol - 256 + 1]};\n                $length += bits2int_lsb($in_fh, $LL_bits, $buffer) if ($LL_bits > 0);\n\n                my $dist_code = '';\n\n                while (1) {\n                    $dist_code .= read_bit_lsb($in_fh, $buffer);\n\n                    if (length($dist_code) > $max_dist_code_len) {\n                        die \"[!] Something went wrong: length of distance code `$dist_code` is > $max_dist_code_len.\\n\";\n                    }\n\n                    if (exists($dist_rev_dict->{$dist_code})) {\n                        last;\n                    }\n                }\n\n                my ($dist, $dist_bits) = @{$DISTANCE_SYMBOLS->[$dist_rev_dict->{$dist_code} + 1]};\n                $dist += bits2int_lsb($in_fh, $dist_bits, $buffer) if ($dist_bits > 0);\n\n                if ($dist == 1) {\n                    $$search_window .= substr($$search_window, -1) x $length;\n                }\n                elsif ($dist >= $length) {    # non-overlapping matches\n                    $$search_window .= substr($$search_window, length($$search_window) - $dist, $length);\n                }\n                else {                        # overlapping matches\n                    foreach my $i (1 .. $length) {\n                        $$search_window .= substr($$search_window, length($$search_window) - $dist, 1);\n                    }\n                }\n\n                $data .= substr($$search_window, -$length);\n            }\n\n            $code = '';\n        }\n    }\n\n    if ($code ne '') {\n        die \"[!] Something went wrong: code `$code` is not empty!\\n\";\n    }\n\n    return $data;\n}\n\nsub extract_block_type_1 ($in_fh, $buffer, $search_window) {\n\n    state $rev_dict;\n    state $dist_rev_dict;\n\n    if (!defined($rev_dict)) {\n\n        my @code_lengths = (0) x 288;\n        foreach my $i (0 .. 143) {\n            $code_lengths[$i] = 8;\n        }\n        foreach my $i (144 .. 255) {\n            $code_lengths[$i] = 9;\n        }\n        foreach my $i (256 .. 279) {\n            $code_lengths[$i] = 7;\n        }\n        foreach my $i (280 .. 287) {\n            $code_lengths[$i] = 8;\n        }\n\n        (undef, $rev_dict)      = huffman_from_code_lengths(\\@code_lengths);\n        (undef, $dist_rev_dict) = huffman_from_code_lengths([(5) x 32]);\n    }\n\n    decode_huffman($in_fh, $buffer, $rev_dict, $dist_rev_dict, $search_window);\n}\n\nsub decode_CL_lengths($in_fh, $buffer, $CL_rev_dict, $size) {\n\n    my @lengths;\n    my $code = '';\n\n    while (1) {\n        $code .= read_bit_lsb($in_fh, $buffer);\n\n        if (length($code) > 7) {\n            die \"[!] Something went wrong: length of CL code `$code` is > 7.\\n\";\n        }\n\n        if (exists($CL_rev_dict->{$code})) {\n            my $CL_symbol = $CL_rev_dict->{$code};\n\n            if ($CL_symbol <= 15) {\n                push @lengths, $CL_symbol;\n            }\n            elsif ($CL_symbol == 16) {\n                push @lengths, ($lengths[-1]) x (3 + bits2int_lsb($in_fh, 2, $buffer));\n            }\n            elsif ($CL_symbol == 17) {\n                push @lengths, (0) x (3 + bits2int_lsb($in_fh, 3, $buffer));\n            }\n            elsif ($CL_symbol == 18) {\n                push @lengths, (0) x (11 + bits2int_lsb($in_fh, 7, $buffer));\n            }\n            else {\n                die \"Unknown CL symbol: $CL_symbol\\n\";\n            }\n\n            $code = '';\n            last if (scalar(@lengths) >= $size);\n        }\n    }\n\n    if (scalar(@lengths) != $size) {\n        die \"Something went wrong: size $size (expected) != \", scalar(@lengths);\n    }\n\n    if ($code ne '') {\n        die \"Something went wrong: code `$code` is not empty!\";\n    }\n\n    return @lengths;\n}\n\nsub extract_block_type_2 ($in_fh, $buffer, $search_window) {\n\n    # (5 bits) HLIT = (number of LL code entries present) - 257\n    my $HLIT = bits2int_lsb($in_fh, 5, $buffer) + 257;\n\n    # (5 bits) HDIST = (number of distance code entries present) - 1\n    my $HDIST = bits2int_lsb($in_fh, 5, $buffer) + 1;\n\n    # (4 bits) HCLEN = (number of CL code entries present) - 4\n    my $HCLEN = bits2int_lsb($in_fh, 4, $buffer) + 4;\n\n    say STDERR \":: Number of LL codes: $HLIT\";\n    say STDERR \":: Number of dist codes: $HDIST\";\n    say STDERR \":: Number of CL codes: $HCLEN\";\n\n    my @CL_code_lenghts = (0) x 19;\n    my @CL_order        = (16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15);\n\n    foreach my $i (0 .. $HCLEN - 1) {\n        $CL_code_lenghts[$CL_order[$i]] = bits2int_lsb($in_fh, 3, $buffer);\n    }\n\n    say STDERR \":: CL code lengths: @CL_code_lenghts\";\n\n    my (undef, $CL_rev_dict) = huffman_from_code_lengths(\\@CL_code_lenghts);\n\n    my @LL_CL_lengths   = decode_CL_lengths($in_fh, $buffer, $CL_rev_dict, $HLIT);\n    my @dist_CL_lengths = decode_CL_lengths($in_fh, $buffer, $CL_rev_dict, $HDIST);\n\n    my (undef, $LL_rev_dict)   = huffman_from_code_lengths(\\@LL_CL_lengths);\n    my (undef, $dist_rev_dict) = huffman_from_code_lengths(\\@dist_CL_lengths);\n\n    decode_huffman($in_fh, $buffer, $LL_rev_dict, $dist_rev_dict, $search_window);\n}\n\nsub extract ($in_fh, $output_file, $defined_output_file) {\n\n    my $MAGIC = (getc($in_fh) // die \"error\") . (getc($in_fh) // die \"error\");\n\n    if ($MAGIC ne pack('C*', 0x1f, 0x8b)) {\n        die \"Not a valid Gzip container!\\n\";\n    }\n\n    my $CM     = getc($in_fh) // die \"error\";                             # 0x08 = DEFLATE\n    my $FLAGS  = ord(getc($in_fh) // die \"error\");                        # flags\n    my $MTIME  = join('', map { getc($in_fh) // die \"error\" } 1 .. 4);    # modification time\n    my $XFLAGS = getc($in_fh) // die \"error\";                             # extra flags\n    my $OS     = getc($in_fh) // die \"error\";                             # 0x03 = Unix\n\n    if ($CM ne chr(0x08)) {\n        die \"Only DEFLATE compression method is supported (0x08)! Got: 0x\", sprintf('%02x', ord($CM));\n    }\n\n    # Reference:\n    #   https://web.archive.org/web/20240221024029/https://forensics.wiki/gzip/\n\n    my $has_filename        = 0;\n    my $has_comment         = 0;\n    my $has_header_checksum = 0;\n    my $has_extra_fields    = 0;\n\n    if ($FLAGS & 0x08) {\n        $has_filename = 1;\n    }\n\n    if ($FLAGS & 0x10) {\n        $has_comment = 1;\n    }\n\n    if ($FLAGS & 0x02) {\n        $has_header_checksum = 1;\n    }\n\n    if ($FLAGS & 0x04) {\n        $has_extra_fields = 1;\n    }\n\n    if ($has_extra_fields) {\n        my $size = bytes2int_lsb($in_fh, 2);\n        read($in_fh, (my $extra_field_data), $size) // die \"can't read extra field data: $!\";\n        say STDERR \":: Extra field data: $extra_field_data\";\n    }\n\n    if ($has_filename) {\n        my $filename = read_null_terminated($in_fh);    # filename\n        say STDERR \":: Filename: \", $filename;\n        if (not $defined_output_file) {\n            $output_file = $filename;\n        }\n    }\n\n    if ($has_comment) {\n        my $comment = read_null_terminated($in_fh);     # comment\n        say STDERR \":: Comment: $comment\";\n    }\n\n    if ($has_header_checksum) {\n        my $header_checksum = bytes2int_lsb($in_fh, 2);\n        say STDERR \":: Header checksum: $header_checksum\";\n    }\n\n    my $out_fh = ref($output_file) eq 'GLOB' ? $output_file : undef;\n    if (!defined($out_fh)) {\n        open $out_fh, '>:raw', $output_file or die \"Can't create file <<$output_file>>: $!\";\n    }\n\n    my $crc32         = 0;\n    my $actual_length = 0;\n    my $buffer        = '';\n    my $search_window = '';\n    my $window_size   = $Compression::Util::LZ_MAX_DIST;\n\n    while (1) {\n\n        my $is_last    = read_bit_lsb($in_fh, \\$buffer);\n        my $block_type = bits2int_lsb($in_fh, 2, \\$buffer);\n\n        my $chunk = '';\n\n        if ($block_type == 0) {\n            say STDERR \"\\n:: Extracting block of type 0\";\n            $buffer = '';                                       # pad to a byte\n            $chunk  = extract_block_type_0($in_fh, \\$buffer);\n            $search_window .= $chunk;\n        }\n        elsif ($block_type == 1) {\n            say STDERR \"\\n:: Extracting block of type 1\";\n            $chunk = extract_block_type_1($in_fh, \\$buffer, \\$search_window);\n        }\n        elsif ($block_type == 2) {\n            say STDERR \"\\n:: Extracting block of type 2\";\n            $chunk = extract_block_type_2($in_fh, \\$buffer, \\$search_window);\n        }\n        else {\n            die \"[!] Unknown block of type: $block_type\";\n        }\n\n        print $out_fh $chunk;\n        $crc32 = crc32($chunk, $crc32);\n        $actual_length += length($chunk);\n        $search_window = substr($search_window, -$window_size) if (length($search_window) > 2 * $window_size);\n\n        last if $is_last;\n    }\n\n    $buffer = '';    # discard any padding bits\n\n    my $stored_crc32 = bits2int_lsb($in_fh, 32, \\$buffer);\n    my $actual_crc32 = $crc32;\n\n    say STDERR '';\n\n    if ($stored_crc32 != $actual_crc32) {\n        print STDERR \"[!] The CRC32 does not match: $actual_crc32 (actual) != $stored_crc32 (stored)\\n\";\n    }\n    else {\n        print STDERR \":: CRC32 value: $actual_crc32\\n\";\n    }\n\n    my $stored_length = bits2int_lsb($in_fh, 32, \\$buffer);\n\n    if ($stored_length != $actual_length) {\n        print STDERR \"[!] The length does not match: $actual_length (actual) != $stored_length (stored)\\n\";\n    }\n    else {\n        print STDERR \":: Total length: $actual_length\\n\";\n    }\n\n    if (eof($in_fh)) {\n        print STDERR \"\\n:: Reached the end of the file.\\n\";\n    }\n    else {\n        print STDERR \"\\n:: There is something else in the container! Trying to recurse!\\n\\n\";\n        __SUB__->($in_fh, $out_fh, 1);\n    }\n}\n\nif (-t STDIN) {\n    my $input  = $ARGV[0] // die \"usage: $0 [input] [output.gz]\\n\";\n    my $output = $ARGV[1] // ($input =~ s/\\.gz\\z//ir);\n    open my $fh, '<:raw', $input or die \"Can't open file <<$input>> for reading: $!\";\n    extract($fh, $output, defined($ARGV[1]));\n}\nelse {\n    extract(\\*STDIN, \\*STDOUT, 1);\n}\n"
  },
  {
    "path": "Compression/gzip_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 05 May 2024\n# https://github.com/trizen\n\n# A valid Gzip file compressor/decompressor, generating DEFLATE blocks of type 0, 1 or 2, whichever is smaller.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\nuse List::Util        qw(all min max);\nuse Getopt::Std       qw(getopts);\n\nuse constant {\n              FORMAT     => 'gz',\n              CHUNK_SIZE => (1 << 16) - 1,    # increased for better LZ matching\n             };\n\nlocal $Compression::Util::LZ_MIN_LEN       = 3;                # minimum match length in LZ parsing (DEFLATE supports 3)\nlocal $Compression::Util::LZ_MAX_LEN       = 258;              # maximum match length in LZ parsing\nlocal $Compression::Util::LZ_MAX_DIST      = (1 << 15) - 1;    # maximum allowed back-reference distance in LZ parsing\nlocal $Compression::Util::LZ_MAX_CHAIN_LEN = 128;              # more thorough match search\n\nmy $MAGIC  = pack('C*', 0x1f, 0x8b);                           # magic MIME type\nmy $CM     = chr(0x08);                                        # 0x08 = DEFLATE\nmy $FLAGS  = chr(0x00);                                        # flags\nmy $MTIME  = pack('C*', (0x00) x 4);                           # modification time\nmy $XFLAGS = chr(0x00);                                        # extra flags\nmy $OS     = chr(0x03);                                        # 0x03 = Unix\n\nmy ($DISTANCE_SYMBOLS, $LENGTH_SYMBOLS, $LENGTH_INDICES) = make_deflate_tables();\n\nmy @DISTANCE_INDICES;\nforeach my $i (0 .. $#$DISTANCE_SYMBOLS) {\n    my $min = $DISTANCE_SYMBOLS->[$i][0];\n    my $max = ($i < $#$DISTANCE_SYMBOLS)\n            ? $DISTANCE_SYMBOLS->[$i + 1][0] - 1\n            : $Compression::Util::LZ_MAX_DIST;\n    foreach my $d ($min .. $max) {\n        $DISTANCE_INDICES[$d] = $i;\n    }\n}\n\nsub usage ($code = 0) {\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\n#################\n# GZIP COMPRESSOR\n#################\n\nsub code_length_encoding ($dict) {\n\n    my @lengths;\n\n    foreach my $symbol (0 .. max(keys %$dict) // 0) {\n        if (exists($dict->{$symbol})) {\n            push @lengths, length($dict->{$symbol});\n        }\n        else {\n            push @lengths, 0;\n        }\n    }\n\n    my $size        = scalar(@lengths);\n    my $rl          = run_length(\\@lengths);\n    my $offset_bits = '';\n\n    my @CL_symbols;\n\n    foreach my $pair (@$rl) {\n        my ($v, $run) = @$pair;\n\n        while ($v == 0 and $run >= 3) {\n\n            if ($run >= 11) {\n                push @CL_symbols, 18;\n                my $extra = min($run - 11, 127);\n                $offset_bits .= int2bits_lsb($extra, 7);\n                $run -= 11 + $extra;\n            }\n\n            if ($run >= 3 and $run < 11) {\n                push @CL_symbols, 17;\n                my $extra = min($run - 3, 7);\n                $offset_bits .= int2bits_lsb($extra, 3);\n                $run -= 3 + $extra;\n            }\n        }\n\n        if ($v == 0) {\n            push(@CL_symbols, (0) x $run) if ($run > 0);\n            next;\n        }\n\n        push @CL_symbols, $v;\n        $run -= 1;\n\n        while ($run >= 3) {\n            push @CL_symbols, 16;\n            my $extra = min($run - 3, 3);\n            $offset_bits .= int2bits_lsb($extra, 2);\n            $run -= 3 + $extra;\n        }\n\n        push(@CL_symbols, ($v) x $run) if ($run > 0);\n    }\n\n    return (\\@CL_symbols, $size, $offset_bits);\n}\n\nsub cl_encoded_bitstring ($cl_dict, $cl_symbols, $offset_bits) {\n\n    my $bitstring = '';\n    foreach my $cl_symbol (@$cl_symbols) {\n        $bitstring .= $cl_dict->{$cl_symbol};\n        if ($cl_symbol == 16) {\n            $bitstring .= substr($offset_bits, 0, 2, '');\n        }\n        elsif ($cl_symbol == 17) {\n            $bitstring .= substr($offset_bits, 0, 3, '');\n        }\n        elsif ($cl_symbol == 18) {\n            $bitstring .= substr($offset_bits, 0, 7, '');\n        }\n    }\n\n    return $bitstring;\n}\n\nsub create_cl_dictionary (@cl_symbols) {\n\n    my @keys;\n    my $freq = frequencies(\\@cl_symbols);\n\n    while (1) {\n        my ($cl_dict) = huffman_from_freq($freq);\n\n        # The CL codes must have at most 7 bits\n        return $cl_dict if all { length($_) <= 7 } values %$cl_dict;\n\n        if (scalar(@keys) == 0) {\n            @keys = sort { $freq->{$b} <=> $freq->{$a} } keys %$freq;\n        }\n\n        # Scale down the frequencies and try again\n        foreach my $k (@keys) {\n            if ($freq->{$k} > 1) {\n                $freq->{$k} >>= 1;\n            }\n            else {\n                last;\n            }\n        }\n    }\n}\n\nsub block_type_2 ($literals, $distances, $lengths) {\n\n    my @CL_order = (16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15);\n\n    my @parts;\n    push @parts, '01';\n\n    my @len_symbols;\n    my @dist_symbols;\n    my $offset_bits = '';\n\n    foreach my $k (0 .. $#$literals) {\n\n        if ($lengths->[$k] == 0) {\n            push @len_symbols, $literals->[$k];\n            next;\n        }\n\n        my $len  = $lengths->[$k];\n        my $dist = $distances->[$k];\n\n        {\n            my $len_idx = $LENGTH_INDICES->[$len];\n            my ($min, $bits) = @{$LENGTH_SYMBOLS->[$len_idx]};\n\n            push @len_symbols, [$len_idx + 256 - 1, $bits];\n            $offset_bits .= int2bits_lsb($len - $min, $bits) if ($bits > 0);\n        }\n\n        {\n            my $dist_idx = $DISTANCE_INDICES[$dist];\n            my ($min, $bits) = @{$DISTANCE_SYMBOLS->[$dist_idx]};\n\n            push @dist_symbols, [$dist_idx - 1, $bits];\n            $offset_bits .= int2bits_lsb($dist - $min, $bits) if ($bits > 0);\n        }\n    }\n\n    push @len_symbols, 256;    # end-of-block marker\n\n    my ($dict)      = huffman_from_symbols([map { ref($_) eq 'ARRAY' ? $_->[0] : $_ } @len_symbols]);\n    my ($dist_dict) = huffman_from_symbols([map { $_->[0] } @dist_symbols]);\n\n    my ($LL_code_lengths,       $LL_cl_len,       $LL_offset_bits)       = code_length_encoding($dict);\n    my ($distance_code_lengths, $distance_cl_len, $distance_offset_bits) = code_length_encoding($dist_dict);\n\n    my $cl_dict = create_cl_dictionary(@$LL_code_lengths, @$distance_code_lengths);\n\n    my @CL_code_lenghts;\n    foreach my $symbol (0 .. 18) {\n        if (exists($cl_dict->{$symbol})) {\n            push @CL_code_lenghts, length($cl_dict->{$symbol});\n        }\n        else {\n            push @CL_code_lenghts, 0;\n        }\n    }\n\n    # Put the CL codes in the required order\n    @CL_code_lenghts = @CL_code_lenghts[@CL_order];\n\n    while (scalar(@CL_code_lenghts) > 4 and $CL_code_lenghts[-1] == 0) {\n        pop @CL_code_lenghts;\n    }\n\n    my $CL_code_lengths_bitstring = join('', map { int2bits_lsb($_, 3) } @CL_code_lenghts);\n\n    my $LL_code_lengths_bitstring       = cl_encoded_bitstring($cl_dict, $LL_code_lengths,       $LL_offset_bits);\n    my $distance_code_lengths_bitstring = cl_encoded_bitstring($cl_dict, $distance_code_lengths, $distance_offset_bits);\n\n    # (5 bits) HLIT = (number of LL code entries present) - 257\n    my $HLIT = $LL_cl_len - 257;\n\n    # (5 bits) HDIST = (number of distance code entries present) - 1\n    my $HDIST = $distance_cl_len - 1;\n\n    # (4 bits) HCLEN = (number of CL code entries present) - 4\n    my $HCLEN = scalar(@CL_code_lenghts) - 4;\n\n    push @parts, int2bits_lsb($HLIT,  5);\n    push @parts, int2bits_lsb($HDIST, 5);\n    push @parts, int2bits_lsb($HCLEN, 4);\n\n    push @parts, $CL_code_lengths_bitstring;\n    push @parts, $LL_code_lengths_bitstring;\n    push @parts, $distance_code_lengths_bitstring;\n\n    foreach my $symbol (@len_symbols) {\n        if (ref($symbol) eq 'ARRAY') {\n\n            my ($len, $len_offset) = @$symbol;\n            push @parts, $dict->{$len};\n            push @parts, substr($offset_bits, 0, $len_offset, '') if ($len_offset > 0);\n\n            my ($dist, $dist_offset) = @{shift(@dist_symbols)};\n            push @parts, $dist_dict->{$dist};\n            push @parts, substr($offset_bits, 0, $dist_offset, '') if ($dist_offset > 0);\n        }\n        else {\n            push @parts, $dict->{$symbol};\n        }\n    }\n\n    my $bitstring = join('', @parts);\n\n    return $bitstring;\n}\n\nsub block_type_1 ($literals, $distances, $lengths) {\n\n    state $dict;\n    state $dist_dict;\n\n    if (!defined($dict)) {\n\n        my @code_lengths = (0) x 288;\n        foreach my $i (0 .. 143) {\n            $code_lengths[$i] = 8;\n        }\n        foreach my $i (144 .. 255) {\n            $code_lengths[$i] = 9;\n        }\n        foreach my $i (256 .. 279) {\n            $code_lengths[$i] = 7;\n        }\n        foreach my $i (280 .. 287) {\n            $code_lengths[$i] = 8;\n        }\n\n        ($dict)      = huffman_from_code_lengths(\\@code_lengths);\n        ($dist_dict) = huffman_from_code_lengths([(5) x 32]);\n    }\n\n    my @parts;\n    push @parts, '10';\n\n    foreach my $k (0 .. $#$literals) {\n\n        if ($lengths->[$k] == 0) {\n            push @parts, $dict->{$literals->[$k]};\n            next;\n        }\n\n        my $len  = $lengths->[$k];\n        my $dist = $distances->[$k];\n\n        {\n            my $len_idx = $LENGTH_INDICES->[$len];\n            my ($min, $bits) = @{$LENGTH_SYMBOLS->[$len_idx]};\n\n            push @parts, $dict->{$len_idx + 256 - 1};\n            push @parts, int2bits_lsb($len - $min, $bits) if ($bits > 0);\n        }\n\n        {\n            my $dist_idx = $DISTANCE_INDICES[$dist];\n            my ($min, $bits) = @{$DISTANCE_SYMBOLS->[$dist_idx]};\n\n            push @parts, $dist_dict->{$dist_idx - 1};\n            push @parts, int2bits_lsb($dist - $min, $bits) if ($bits > 0);\n        }\n    }\n\n    push @parts, $dict->{256};    # end-of-block symbol\n\n    my $bitstring = join('', @parts);\n\n    return $bitstring;\n}\n\nsub block_type_0($chunk) {\n\n    my $chunk_len = length($chunk);\n    my $len       = int2bits_lsb($chunk_len,             16);\n    my $nlen      = int2bits_lsb((~$chunk_len) & 0xffff, 16);\n\n    $len . $nlen;\n}\n\nsub my_gzip_compress ($in_fh, $out_fh) {\n\n    print $out_fh $MAGIC, $CM, $FLAGS, $MTIME, $XFLAGS, $OS;\n\n    my $total_length = 0;\n    my $crc32        = 0;\n\n    my $bitstring = '';\n\n    if (eof($in_fh)) {    # empty file\n        $bitstring = '1' . '10' . '0000000';\n    }\n\n    while (read($in_fh, (my $chunk), CHUNK_SIZE)) {\n\n        $crc32 = crc32($chunk, $crc32);\n        $total_length += length($chunk);\n\n        my ($literals, $distances, $lengths) = lzss_encode($chunk);\n\n        $bitstring .= eof($in_fh) ? '1' : '0';\n\n        my $bt0_size      = (length($chunk) + 5) * 8;    # type 0 cost in bits\n        my $bt1_bitstring = block_type_1($literals, $distances, $lengths);\n\n        if ($bt0_size <= length($bt1_bitstring)) {\n            # Block type 0 is cheapest — skip computing type 2\n            say STDERR \":: Using block type: 0\";\n            $bitstring .= '00';\n\n            print $out_fh pack('b*', $bitstring);             # pads to a byte\n            print $out_fh pack('b*', block_type_0($chunk));\n            print $out_fh $chunk;\n\n            $bitstring = '';\n            next;\n        }\n\n        my $bt2_bitstring = block_type_2($literals, $distances, $lengths);\n\n        # When block type 2 is larger than block type 1, then we may have very small data\n        if (length($bt2_bitstring) > length($bt1_bitstring)) {\n            say STDERR \":: Using block type: 1\";\n            $bitstring .= $bt1_bitstring;\n        }\n        else {\n            say STDERR \":: Using block type: 2\";\n            $bitstring .= $bt2_bitstring;\n        }\n\n        print $out_fh pack('b*', substr($bitstring, 0, length($bitstring) - (length($bitstring) % 8), ''));\n    }\n\n    if ($bitstring ne '') {\n        print $out_fh pack('b*', $bitstring);\n    }\n\n    print $out_fh pack('b*', int2bits_lsb($crc32,        32));\n    print $out_fh pack('b*', int2bits_lsb($total_length, 32));\n\n    return 1;\n}\n\n###################\n# GZIP DECOMPRESSOR\n###################\n\nsub extract_block_type_0 ($in_fh, $buffer) {\n\n    my $len           = bits2int_lsb($in_fh, 16, $buffer);\n    my $nlen          = bits2int_lsb($in_fh, 16, $buffer);\n    my $expected_nlen = (~$len) & 0xffff;\n\n    if ($expected_nlen != $nlen) {\n        die \"[!] The ~length value is not correct: $nlen (actual) != $expected_nlen (expected)\\n\";\n    }\n    else {\n        print STDERR \":: Chunk length: $len\\n\";\n    }\n\n    read($in_fh, (my $chunk), $len);\n    return $chunk;\n}\n\nsub decode_huffman($in_fh, $buffer, $rev_dict, $dist_rev_dict, $search_window) {\n\n    my $data = '';\n    my $code = '';\n\n    my $max_ll_code_len   = max(map { length($_) } keys %$rev_dict);\n    my $max_dist_code_len = max(map { length($_) } keys %$dist_rev_dict);\n\n    while (1) {\n        $code .= read_bit_lsb($in_fh, $buffer);\n\n        if (length($code) > $max_ll_code_len) {\n            die \"[!] Something went wrong: length of LL code `$code` is > $max_ll_code_len.\\n\";\n        }\n\n        if (exists($rev_dict->{$code})) {\n\n            my $symbol = $rev_dict->{$code};\n\n            if ($symbol <= 255) {\n                $data           .= chr($symbol);\n                $$search_window .= chr($symbol);\n            }\n            elsif ($symbol == 256) {    # end-of-block marker\n                $code = '';\n                last;\n            }\n            else {                      # LZSS decoding\n                my ($length, $LL_bits) = @{$LENGTH_SYMBOLS->[$symbol - 256 + 1]};\n                $length += bits2int_lsb($in_fh, $LL_bits, $buffer) if ($LL_bits > 0);\n\n                my $dist_code = '';\n\n                while (1) {\n                    $dist_code .= read_bit_lsb($in_fh, $buffer);\n\n                    if (length($dist_code) > $max_dist_code_len) {\n                        die \"[!] Something went wrong: length of distance code `$dist_code` is > $max_dist_code_len.\\n\";\n                    }\n\n                    if (exists($dist_rev_dict->{$dist_code})) {\n                        last;\n                    }\n                }\n\n                my ($dist, $dist_bits) = @{$DISTANCE_SYMBOLS->[$dist_rev_dict->{$dist_code} + 1]};\n                $dist += bits2int_lsb($in_fh, $dist_bits, $buffer) if ($dist_bits > 0);\n\n                if ($dist == 1) {\n                    $$search_window .= substr($$search_window, -1) x $length;\n                }\n                elsif ($dist >= $length) {    # non-overlapping matches\n                    $$search_window .= substr($$search_window, length($$search_window) - $dist, $length);\n                }\n                else {                        # overlapping matches\n                    my $sw_len = length($$search_window);\n                    foreach my $i (1 .. $length) {\n                        $$search_window .= substr($$search_window, $sw_len - $dist, 1);\n                        $sw_len++;\n                    }\n                }\n\n                $data .= substr($$search_window, -$length);\n            }\n\n            $code = '';\n        }\n    }\n\n    if ($code ne '') {\n        die \"[!] Something went wrong: code `$code` is not empty!\\n\";\n    }\n\n    return $data;\n}\n\nsub extract_block_type_1 ($in_fh, $buffer, $search_window) {\n\n    state $rev_dict;\n    state $dist_rev_dict;\n\n    if (!defined($rev_dict)) {\n\n        my @code_lengths = (0) x 288;\n        foreach my $i (0 .. 143) {\n            $code_lengths[$i] = 8;\n        }\n        foreach my $i (144 .. 255) {\n            $code_lengths[$i] = 9;\n        }\n        foreach my $i (256 .. 279) {\n            $code_lengths[$i] = 7;\n        }\n        foreach my $i (280 .. 287) {\n            $code_lengths[$i] = 8;\n        }\n\n        (undef, $rev_dict)      = huffman_from_code_lengths(\\@code_lengths);\n        (undef, $dist_rev_dict) = huffman_from_code_lengths([(5) x 32]);\n    }\n\n    decode_huffman($in_fh, $buffer, $rev_dict, $dist_rev_dict, $search_window);\n}\n\nsub decode_CL_lengths($in_fh, $buffer, $CL_rev_dict, $size) {\n\n    my @lengths;\n    my $code = '';\n\n    while (1) {\n        $code .= read_bit_lsb($in_fh, $buffer);\n\n        if (length($code) > 7) {\n            die \"[!] Something went wrong: length of CL code `$code` is > 7.\\n\";\n        }\n\n        if (exists($CL_rev_dict->{$code})) {\n            my $CL_symbol = $CL_rev_dict->{$code};\n\n            if ($CL_symbol <= 15) {\n                push @lengths, $CL_symbol;\n            }\n            elsif ($CL_symbol == 16) {\n                push @lengths, ($lengths[-1]) x (3 + bits2int_lsb($in_fh, 2, $buffer));\n            }\n            elsif ($CL_symbol == 17) {\n                push @lengths, (0) x (3 + bits2int_lsb($in_fh, 3, $buffer));\n            }\n            elsif ($CL_symbol == 18) {\n                push @lengths, (0) x (11 + bits2int_lsb($in_fh, 7, $buffer));\n            }\n            else {\n                die \"Unknown CL symbol: $CL_symbol\\n\";\n            }\n\n            $code = '';\n            last if (scalar(@lengths) >= $size);\n        }\n    }\n\n    if (scalar(@lengths) != $size) {\n        die \"Something went wrong: size $size (expected) != \", scalar(@lengths);\n    }\n\n    if ($code ne '') {\n        die \"Something went wrong: code `$code` is not empty!\";\n    }\n\n    return @lengths;\n}\n\nsub extract_block_type_2 ($in_fh, $buffer, $search_window) {\n\n    # (5 bits) HLIT = (number of LL code entries present) - 257\n    my $HLIT = bits2int_lsb($in_fh, 5, $buffer) + 257;\n\n    # (5 bits) HDIST = (number of distance code entries present) - 1\n    my $HDIST = bits2int_lsb($in_fh, 5, $buffer) + 1;\n\n    # (4 bits) HCLEN = (number of CL code entries present) - 4\n    my $HCLEN = bits2int_lsb($in_fh, 4, $buffer) + 4;\n\n    say STDERR \":: Number of LL codes: $HLIT\";\n    say STDERR \":: Number of dist codes: $HDIST\";\n    say STDERR \":: Number of CL codes: $HCLEN\";\n\n    my @CL_code_lenghts = (0) x 19;\n    my @CL_order        = (16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15);\n\n    foreach my $i (0 .. $HCLEN - 1) {\n        $CL_code_lenghts[$CL_order[$i]] = bits2int_lsb($in_fh, 3, $buffer);\n    }\n\n    say STDERR \":: CL code lengths: @CL_code_lenghts\";\n\n    my (undef, $CL_rev_dict) = huffman_from_code_lengths(\\@CL_code_lenghts);\n\n    my @LL_CL_lengths   = decode_CL_lengths($in_fh, $buffer, $CL_rev_dict, $HLIT);\n    my @dist_CL_lengths = decode_CL_lengths($in_fh, $buffer, $CL_rev_dict, $HDIST);\n\n    my (undef, $LL_rev_dict)   = huffman_from_code_lengths(\\@LL_CL_lengths);\n    my (undef, $dist_rev_dict) = huffman_from_code_lengths(\\@dist_CL_lengths);\n\n    decode_huffman($in_fh, $buffer, $LL_rev_dict, $dist_rev_dict, $search_window);\n}\n\nsub my_gzip_decompress ($in_fh, $out_fh) {\n\n    my $MAGIC = (getc($in_fh) // die \"error\") . (getc($in_fh) // die \"error\");\n\n    if ($MAGIC ne pack('C*', 0x1f, 0x8b)) {\n        die \"Not a valid Gzip container!\\n\";\n    }\n\n    my $CM     = getc($in_fh) // die \"error\";                             # 0x08 = DEFLATE\n    my $FLAGS  = ord(getc($in_fh) // die \"error\");                        # flags\n    my $MTIME  = join('', map { getc($in_fh) // die \"error\" } 1 .. 4);    # modification time\n    my $XFLAGS = getc($in_fh) // die \"error\";                             # extra flags\n    my $OS     = getc($in_fh) // die \"error\";                             # 0x03 = Unix\n\n    if ($CM ne chr(0x08)) {\n        die \"Only DEFLATE compression method is supported (0x08)! Got: 0x\", sprintf('%02x', ord($CM));\n    }\n\n    # Reference:\n    #   https://web.archive.org/web/20240221024029/https://forensics.wiki/gzip/\n\n    my $has_filename        = 0;\n    my $has_comment         = 0;\n    my $has_header_checksum = 0;\n    my $has_extra_fields    = 0;\n\n    if ($FLAGS & 0x08) {\n        $has_filename = 1;\n    }\n\n    if ($FLAGS & 0x10) {\n        $has_comment = 1;\n    }\n\n    if ($FLAGS & 0x02) {\n        $has_header_checksum = 1;\n    }\n\n    if ($FLAGS & 0x04) {\n        $has_extra_fields = 1;\n    }\n\n    if ($has_extra_fields) {\n        my $size = bytes2int_lsb($in_fh, 2);\n        read($in_fh, (my $extra_field_data), $size) // die \"can't read extra field data: $!\";\n        say STDERR \":: Extra field data: $extra_field_data\";\n    }\n\n    if ($has_filename) {\n        my $filename = read_null_terminated($in_fh);    # filename\n        say STDERR \":: Filename: $filename\";\n    }\n\n    if ($has_comment) {\n        my $comment = read_null_terminated($in_fh);     # comment\n        say STDERR \":: Comment: $comment\";\n    }\n\n    if ($has_header_checksum) {\n        my $header_checksum = bytes2int_lsb($in_fh, 2);\n        say STDERR \":: Header checksum: $header_checksum\";\n    }\n\n    my $crc32         = 0;\n    my $actual_length = 0;\n    my $buffer        = '';\n    my $search_window = '';\n    my $window_size   = $Compression::Util::LZ_MAX_DIST;\n\n    while (1) {\n\n        my $is_last    = read_bit_lsb($in_fh, \\$buffer);\n        my $block_type = bits2int_lsb($in_fh, 2, \\$buffer);\n\n        my $chunk = '';\n\n        if ($block_type == 0) {\n            say STDERR \"\\n:: Extracting block of type 0\";\n            $buffer = '';                                       # pad to a byte\n            $chunk  = extract_block_type_0($in_fh, \\$buffer);\n            $search_window .= $chunk;\n        }\n        elsif ($block_type == 1) {\n            say STDERR \"\\n:: Extracting block of type 1\";\n            $chunk = extract_block_type_1($in_fh, \\$buffer, \\$search_window);\n        }\n        elsif ($block_type == 2) {\n            say STDERR \"\\n:: Extracting block of type 2\";\n            $chunk = extract_block_type_2($in_fh, \\$buffer, \\$search_window);\n        }\n        else {\n            die \"[!] Unknown block of type: $block_type\";\n        }\n\n        print $out_fh $chunk;\n        $crc32 = crc32($chunk, $crc32);\n        $actual_length += length($chunk);\n        $search_window = substr($search_window, -$window_size) if (length($search_window) > 2 * $window_size);\n\n        last if $is_last;\n    }\n\n    $buffer = '';    # discard any padding bits\n\n    my $stored_crc32 = bits2int_lsb($in_fh, 32, \\$buffer);\n    my $actual_crc32 = $crc32;\n\n    say STDERR '';\n\n    if ($stored_crc32 != $actual_crc32) {\n        print STDERR \"[!] The CRC32 does not match: $actual_crc32 (actual) != $stored_crc32 (stored)\\n\";\n    }\n    else {\n        print STDERR \":: CRC32 value: $actual_crc32\\n\";\n    }\n\n    my $stored_length = bits2int_lsb($in_fh, 32, \\$buffer);\n\n    if ($stored_length != $actual_length) {\n        print STDERR \"[!] The length does not match: $actual_length (actual) != $stored_length (stored)\\n\";\n    }\n    else {\n        print STDERR \":: Total length: $actual_length\\n\";\n    }\n\n    if (eof($in_fh)) {\n        print STDERR \"\\n:: Reached the end of the file.\\n\";\n    }\n    else {\n        print STDERR \"\\n:: There is something else in the container! Trying to recurse!\\n\\n\";\n        __SUB__->($in_fh, $out_fh);\n    }\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        open my $in_fh, '<:raw', $input\n          or die \"Can't open file <<$input>> for reading: $!\";\n\n        open my $out_fh, '>:raw', $output\n          or die \"Can't open file <<$output>> for writing: $!\";\n\n        my_gzip_decompress($in_fh, $out_fh)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n\n        open my $in_fh, '<:raw', $input\n          or die \"Can't open file <<$input>> for reading: $!\";\n\n        open my $out_fh, '>:raw', $output\n          or die \"Can't open file <<$output>> for writing: $!\";\n\n        my_gzip_compress($in_fh, $out_fh)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/gzip_store.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 13 January 2024\n# https://github.com/trizen\n\n# Create a valid Gzip container, with uncompressed data.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\nuse Compression::Util qw(crc32);\nuse File::Basename    qw(basename);\n\nuse constant {\n              CHUNK_SIZE => 0xffff,    # 2^16 - 1\n             };\n\nmy $MAGIC  = pack('C*', 0x1f, 0x8b);    # magic MIME type\nmy $CM     = chr(0x08);                 # 0x08 = DEFLATE\nmy $FLAGS  = chr(0x00);                 # flags\nmy $MTIME  = pack('C*', (0x00) x 4);    # modification time\nmy $XFLAGS = chr(0x00);                 # extra flags\nmy $OS     = chr(0x03);                 # 0x03 = Unix\n\nmy $input  = $ARGV[0] // die \"usage: $0 [input] [output.gz]\\n\";\nmy $output = $ARGV[1] // (basename($input) . '.gz');\n\nsub int2bits ($value, $size = 32) {\n    scalar reverse sprintf(\"%0*b\", $size, $value);\n}\n\nopen my $in_fh, '<:raw', $input\n  or die \"Can't open file <<$input>> for reading: $!\";\n\nopen my $out_fh, '>:raw', $output\n  or die \"Can't open file <<$output>> for writing: $!\";\n\nprint $out_fh $MAGIC, $CM, $FLAGS, $MTIME, $XFLAGS, $OS;\n\nmy $total_length = 0;\nmy $block_type   = '00';    # 00 = store; 10 = LZSS + Fixed codes; 01 = LZSS + Dynamic codes\nmy $crc32        = 0;\n\nwhile (read($in_fh, (my $chunk), CHUNK_SIZE)) {\n\n    my $chunk_len = length($chunk);\n    my $len       = int2bits($chunk_len,             16);\n    my $nlen      = int2bits((~$chunk_len) & 0xffff, 16);\n\n    my $is_last      = eof($in_fh) ? '1' : '0';\n    my $block_header = pack('b*', $is_last . $block_type . ('0' x 5) . $len . $nlen);\n\n    print $out_fh $block_header;\n    print $out_fh $chunk;\n\n    $crc32 = crc32($chunk, $crc32);\n    $total_length += $chunk_len;\n}\n\nprint $out_fh pack('b*', int2bits($crc32,        32));\nprint $out_fh pack('b*', int2bits($total_length, 32));\n\nclose $in_fh;\nclose $out_fh;\n"
  },
  {
    "path": "Compression/hfm_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 01 December 2022\n# Edit: 28 April 2023\n# https://github.com/trizen\n\n# Compress/decompress files using Huffman coding.\n\n# Huffman coding algorithm from:\n#   https://rosettacode.org/wiki/Huffman_coding#Perl\n\n# See also:\n#   https://en.wikipedia.org/wiki/Huffman_coding\n\nuse 5.036;\nuse List::Util     qw(min max);\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\n\nuse constant {\n              PKGNAME => 'HFM',\n              VERSION => '0.03',\n              FORMAT  => 'hfm',\n             };\n\nuse constant {\n              CHUNK_SIZE => 1 << 15,\n              SIGNATURE  => uc(FORMAT) . chr(3),\n             };\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub delta_encode ($integers) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1}/gr;    # very fast\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub compress ($input, $output) {\n\n    # Open the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    # Open the output file and write the archive signature\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    print $out_fh SIGNATURE;\n\n    # Read and encode\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        create_huffman_entry([unpack('C*', $chunk)], $out_fh);\n    }\n\n    return 1;\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub decode_huffman_entry ($fh, $out_fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    foreach my $k (keys %$rev_dict) {\n        $rev_dict->{$k} = chr($rev_dict->{$k});\n    }\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n\n    if ($enc_len > 0) {\n        print $out_fh huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n        return 1;\n    }\n\n    return 0;\n}\n\nsub decompress ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    # Decode\n    while (!eof($fh)) {\n        decode_huffman_entry($fh, $out_fh) || last;\n    }\n\n    return 1;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lz4_compressor.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 23 August 2024\n# https://github.com/trizen\n\n# A simple LZ4 compressor.\n\n# References:\n#   https://github.com/lz4/lz4/blob/dev/doc/lz4_Frame_format.md\n#   https://github.com/lz4/lz4/blob/dev/doc/lz4_Block_format.md\n\n# See also:\n#   https://github.com/trizen/Compression-Util\n\nuse 5.036;\nuse Compression::Util qw(:all);\n\nuse constant {CHUNK_SIZE => 1 << 17};\n\nlocal $| = 1;\n\nbinmode(STDIN,  \":raw\");\nbinmode(STDOUT, \":raw\");\n\nmy $s = \"abcabcabc\\n\";\n\nmy $fh;\nif (-t STDIN) {\n    open $fh, \"<:raw\", \\$s;\n}\nelse {\n    $fh = \\*STDIN;\n}\n\nmy $compressed = '';\n\n$compressed .= int2bytes_lsb(0x184D2204, 4);    # LZ4 magic number\n\nmy $fd = '';                                    # frame description\n$fd .= chr(0b01_10_00_00);                      # flags (FLG)\n$fd .= chr(0b0_111_0000);                       # block description (BD)\n\n$compressed .= $fd;\n\n# Header Checksum\nif (eval { require Digest::xxHash; 1 }) {\n    $compressed .= chr((Digest::xxHash::xxhash32($fd, 0) >> 8) & 0xFF);\n}\nelse {\n    $compressed .= chr(115);\n}\n\nwhile (!eof($fh)) {\n\n    read($fh, (my $chunk), CHUNK_SIZE);\n\n    my ($literals, $distances, $lengths) = do {\n        local $Compression::Util::LZ_MIN_LEN       = 4;                # minimum match length\n        local $Compression::Util::LZ_MAX_LEN       = ~0;               # maximum match length\n        local $Compression::Util::LZ_MAX_DIST      = (1 << 16) - 1;    # maximum match distance\n        local $Compression::Util::LZ_MAX_CHAIN_LEN = 32;               # higher value = better compression\n        lzss_encode(substr($chunk, 0, -5));\n    };\n\n    # The last 5 bytes of each block must be literals\n    # https://github.com/lz4/lz4/issues/1495\n    push @$literals, unpack('C*', substr($chunk, -5));\n\n    my $literals_end = $#{$literals};\n\n    my $block = '';\n\n    for (my $i = 0 ; $i <= $literals_end ; ++$i) {\n\n        my @uncompressed;\n        while ($i <= $literals_end and defined($literals->[$i])) {\n            push @uncompressed, $literals->[$i];\n            ++$i;\n        }\n\n        my $literals_string = pack('C*', @uncompressed);\n        my $literals_length = scalar(@uncompressed);\n\n        my $match_len = $lengths->[$i] ? ($lengths->[$i] - 4) : 0;\n\n        my $len_byte = 0;\n\n        $len_byte |= ($literals_length >= 15 ? 15 : $literals_length) << 4;\n        $len_byte |= ($match_len >= 15       ? 15 : $match_len);\n\n        $literals_length -= 15;\n        $match_len       -= 15;\n\n        $block .= chr($len_byte);\n\n        while ($literals_length >= 0) {\n            $block .= ($literals_length >= 255 ? \"\\xff\" : chr($literals_length));\n            $literals_length -= 255;\n        }\n\n        $block .= $literals_string;\n\n        my $dist = $distances->[$i] // last;\n        $block .= pack('b*', scalar reverse sprintf('%016b', $dist));\n\n        while ($match_len >= 0) {\n            $block .= ($match_len >= 255 ? \"\\xff\" : chr($match_len));\n            $match_len -= 255;\n        }\n    }\n\n    if ($block ne '') {\n        $compressed .= int2bytes_lsb(length($block), 4);\n        $compressed .= $block;\n    }\n\n    print $compressed;\n    $compressed = '';\n}\n\nprint int2bytes_lsb(0x00000000, 4);    # EndMark\n"
  },
  {
    "path": "Compression/lz4_decompressor.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 09 May 2024\n# Edit: 08 July 2024\n# https://github.com/trizen\n\n# A simple LZ4 decompressor.\n\n# References:\n#   https://github.com/lz4/lz4/blob/dev/doc/lz4_Frame_format.md\n#   https://github.com/lz4/lz4/blob/dev/doc/lz4_Block_format.md\n\nuse 5.036;\n\nlocal $| = 1;\n\nbinmode(STDIN,  \":raw\");\nbinmode(STDOUT, \":raw\");\n\nsub bytes2int_lsb ($fh, $n) {\n    my $bytes = '';\n    $bytes .= getc($fh) for (1 .. $n);\n    oct('0b' . reverse unpack('b*', $bytes));\n}\n\nmy $s = '';\n\n$s .= \"\\4\\\"M\\30d@\\xA7\\16\\0\\0\\x80Hello, World!\\n\\0\\0\\0\\0\\xE8C\\xD0\\x9E\";            # uncompressed\n$s .= \"\\4\\\"M\\30d@\\xA7\\27\\0\\0\\0\\xE5Hello, World! \\16\\0Prld!\\n\\0\\0\\0\\0\\x9FL\\\"T\";    # compressed\n\nmy $fh;\nif (-t STDIN) {\n    open $fh, \"<:raw\", \\$s;\n}\nelse {\n    $fh = \\*STDIN;\n}\n\nwhile (!eof($fh)) {\n\n    bytes2int_lsb($fh, 4) == 0x184D2204 or die \"Not an LZ4 file\\n\";\n\n    my $FLG = ord(getc($fh));\n    my $BD  = ord(getc($fh));\n\n    my $version    = $FLG & 0b11_00_00_00;\n    my $B_indep    = $FLG & 0b00_10_00_00;\n    my $B_checksum = $FLG & 0b00_01_00_00;\n    my $C_size     = $FLG & 0b00_00_10_00;\n    my $C_checksum = $FLG & 0b00_00_01_00;\n    my $DictID     = $FLG & 0b00_00_00_01;\n\n    my $Block_MaxSize = $BD & 0b0_111_0000;\n\n    say STDERR \"Maximum block size: $Block_MaxSize\";\n\n    if ($version != 0b01_00_00_00) {\n        die \"Error: Invalid version number\";\n    }\n\n    if ($C_size) {\n        my $content_size = bytes2int_lsb($fh, 8);\n        say STDERR \"Content size: \", $content_size;\n    }\n\n    if ($DictID) {\n        my $dict_id = bytes2int_lsb($fh, 4);\n        say STDERR \"Dictionary ID: \", $dict_id;\n    }\n\n    my $header_checksum = ord(getc($fh));\n\n    my $decoded = '';\n\n    while (!eof($fh)) {\n\n        my $block_size = bytes2int_lsb($fh, 4);\n\n        if ($block_size == 0x00000000) {    # signifies an EndMark\n            say STDERR \"Block size == 0\";\n            last;\n        }\n\n        say STDERR \"Block size: $block_size\";\n\n        if ($block_size >> 31) {\n            say STDERR \"Highest bit set: \", $block_size;\n            $block_size &= ((1 << 31) - 1);\n            say STDERR \"Block size: \", $block_size;\n            my $uncompressed = '';\n            read($fh, $uncompressed, $block_size);\n            $decoded .= $uncompressed;\n        }\n        else {\n\n            my $compressed = '';\n            read($fh, $compressed, $block_size);\n\n            while ($compressed ne '') {\n                my $len_byte = ord(substr($compressed, 0, 1, ''));\n\n                my $literals_length = $len_byte >> 4;\n                my $match_len       = $len_byte & 0b1111;\n\n                #say STDERR \"Literal: \",   $literals_length;\n                #say STDERR \"Match len: \", $match_len;\n\n                if ($literals_length == 15) {\n                    while (1) {\n                        my $byte_len = ord(substr($compressed, 0, 1, ''));\n                        $literals_length += $byte_len;\n                        last if $byte_len != 255;\n                    }\n                }\n\n                #say STDERR \"Total literals length: \", $literals_length;\n\n                my $literals = '';\n\n                if ($literals_length > 0) {\n                    $literals = substr($compressed, 0, $literals_length, '');\n                }\n\n                if ($compressed eq '') {    # end of block\n                    $decoded .= $literals;\n                    last;\n                }\n\n                my $offset = oct('0b' . reverse unpack('b16', substr($compressed, 0, 2, '')));\n\n                if ($offset == 0) {\n                    die \"Corrupted block\";\n                }\n\n                # say STDERR \"Offset: $offset\";\n\n                if ($match_len == 15) {\n                    while (1) {\n                        my $byte_len = ord(substr($compressed, 0, 1, ''));\n                        $match_len += $byte_len;\n                        last if $byte_len != 255;\n                    }\n                }\n\n                $decoded .= $literals;\n                $match_len += 4;\n\n                # say STDERR \"Total match len: $match_len\\n\";\n\n                if ($offset >= $match_len) {    # non-overlapping matches\n                    $decoded .= substr($decoded, length($decoded) - $offset, $match_len);\n                }\n                elsif ($offset == 1) {\n                    $decoded .= substr($decoded, -1) x $match_len;\n                }\n                else {                          # overlapping matches\n                    foreach my $i (1 .. $match_len) {\n                        $decoded .= substr($decoded, length($decoded) - $offset, 1);\n                    }\n                }\n            }\n        }\n\n        if ($B_checksum) {\n            my $content_checksum = bytes2int_lsb($fh, 4);\n            say STDERR \"Block checksum: $content_checksum\";\n        }\n\n        if ($B_indep) {    # blocks are independent of each other\n            print $decoded;\n            $decoded = '';\n        }\n        elsif (length($decoded) > 2**16) {    # blocks are dependent\n            print substr($decoded, 0, -(2**16), '');\n        }\n    }\n\n    if ($C_checksum) {\n        my $content_checksum = bytes2int_lsb($fh, 4);\n        say STDERR \"Content checksum: $content_checksum\";\n    }\n\n    print $decoded;\n}\n"
  },
  {
    "path": "Compression/lz4_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 25 August 2024\n# https://github.com/trizen\n\n# A valid LZ4 file compressor/decompressor.\n\n# References:\n#   https://github.com/lz4/lz4/blob/dev/doc/lz4_Frame_format.md\n#   https://github.com/lz4/lz4/blob/dev/doc/lz4_Block_format.md\n\nuse 5.036;\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\nuse Getopt::Std       qw(getopts);\n\nbinmode(STDIN,  \":raw\");\nbinmode(STDOUT, \":raw\");\n\nuse constant {\n              FORMAT     => 'lz4',\n              CHUNK_SIZE => 1 << 17,\n             };\n\nsub usage ($code = 0) {\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub my_lz4_compress($fh, $out_fh) {\n\n    my $compressed = '';\n\n    $compressed .= int2bytes_lsb(0x184D2204, 4);    # LZ4 magic number\n\n    my $fd = '';                                    # frame description\n    $fd .= chr(0b01_10_00_00);                      # flags (FLG)\n    $fd .= chr(0b0_111_0000);                       # block description (BD)\n\n    $compressed .= $fd;\n\n    # Header Checksum\n    if (eval { require Digest::xxHash; 1 }) {\n        $compressed .= chr((Digest::xxHash::xxhash32($fd, 0) >> 8) & 0xFF);\n    }\n    else {\n        $compressed .= chr(115);\n    }\n\n    while (!eof($fh)) {\n\n        read($fh, (my $chunk), CHUNK_SIZE);\n\n        my ($literals, $distances, $lengths) = do {\n            local $Compression::Util::LZ_MIN_LEN       = 4;                # minimum match length\n            local $Compression::Util::LZ_MAX_LEN       = ~0;               # maximum match length\n            local $Compression::Util::LZ_MAX_DIST      = (1 << 16) - 1;    # maximum match distance\n            local $Compression::Util::LZ_MAX_CHAIN_LEN = 32;               # higher value = better compression\n            lzss_encode(substr($chunk, 0, -5));\n        };\n\n        # The last 5 bytes of each block must be literals\n        # https://github.com/lz4/lz4/issues/1495\n        push @$literals, unpack('C*', substr($chunk, -5));\n\n        my $literals_end = $#{$literals};\n\n        my $block = '';\n\n        for (my $i = 0 ; $i <= $literals_end ; ++$i) {\n\n            my @uncompressed;\n            while ($i <= $literals_end and defined($literals->[$i])) {\n                push @uncompressed, $literals->[$i];\n                ++$i;\n            }\n\n            my $literals_string = pack('C*', @uncompressed);\n            my $literals_length = scalar(@uncompressed);\n\n            my $match_len = $lengths->[$i] ? ($lengths->[$i] - 4) : 0;\n\n            my $len_byte = 0;\n\n            $len_byte |= ($literals_length >= 15 ? 15 : $literals_length) << 4;\n            $len_byte |= ($match_len >= 15       ? 15 : $match_len);\n\n            $literals_length -= 15;\n            $match_len       -= 15;\n\n            $block .= chr($len_byte);\n\n            while ($literals_length >= 0) {\n                $block .= ($literals_length >= 255 ? \"\\xff\" : chr($literals_length));\n                $literals_length -= 255;\n            }\n\n            $block .= $literals_string;\n\n            my $dist = $distances->[$i] // last;\n            $block .= pack('b*', scalar reverse sprintf('%016b', $dist));\n\n            while ($match_len >= 0) {\n                $block .= ($match_len >= 255 ? \"\\xff\" : chr($match_len));\n                $match_len -= 255;\n            }\n        }\n\n        if ($block ne '') {\n            $compressed .= int2bytes_lsb(length($block), 4);\n            $compressed .= $block;\n        }\n\n        print $out_fh $compressed;\n        $compressed = '';\n    }\n\n    print $out_fh int2bytes_lsb(0x00000000, 4);    # EndMark\n    return 1;\n}\n\nsub my_lz4_decompress($fh, $out_fh) {\n    while (!eof($fh)) {\n\n        bytes2int_lsb($fh, 4) == 0x184D2204 or die \"Not an LZ4 file\\n\";\n\n        my $FLG = ord(getc($fh));\n        my $BD  = ord(getc($fh));\n\n        my $version    = $FLG & 0b11_00_00_00;\n        my $B_indep    = $FLG & 0b00_10_00_00;\n        my $B_checksum = $FLG & 0b00_01_00_00;\n        my $C_size     = $FLG & 0b00_00_10_00;\n        my $C_checksum = $FLG & 0b00_00_01_00;\n        my $DictID     = $FLG & 0b00_00_00_01;\n\n        my $Block_MaxSize = $BD & 0b0_111_0000;\n\n        say STDERR \"Maximum block size: $Block_MaxSize\";\n\n        if ($version != 0b01_00_00_00) {\n            die \"Error: Invalid version number\";\n        }\n\n        if ($C_size) {\n            my $content_size = bytes2int_lsb($fh, 8);\n            say STDERR \"Content size: \", $content_size;\n        }\n\n        if ($DictID) {\n            my $dict_id = bytes2int_lsb($fh, 4);\n            say STDERR \"Dictionary ID: \", $dict_id;\n        }\n\n        my $header_checksum = ord(getc($fh));\n\n        my $decoded = '';\n\n        while (!eof($fh)) {\n\n            my $block_size = bytes2int_lsb($fh, 4);\n\n            if ($block_size == 0x00000000) {    # signifies an EndMark\n                say STDERR \"Block size == 0\";\n                last;\n            }\n\n            say STDERR \"Block size: $block_size\";\n\n            if ($block_size >> 31) {\n                say STDERR \"Highest bit set: \", $block_size;\n                $block_size &= ((1 << 31) - 1);\n                say STDERR \"Block size: \", $block_size;\n                my $uncompressed = '';\n                read($fh, $uncompressed, $block_size);\n                $decoded .= $uncompressed;\n            }\n            else {\n\n                my $compressed = '';\n                read($fh, $compressed, $block_size);\n\n                while ($compressed ne '') {\n                    my $len_byte = ord(substr($compressed, 0, 1, ''));\n\n                    my $literals_length = $len_byte >> 4;\n                    my $match_len       = $len_byte & 0b1111;\n\n                    #say STDERR \"Literal: \",   $literals_length;\n                    #say STDERR \"Match len: \", $match_len;\n\n                    if ($literals_length == 15) {\n                        while (1) {\n                            my $byte_len = ord(substr($compressed, 0, 1, ''));\n                            $literals_length += $byte_len;\n                            last if $byte_len != 255;\n                        }\n                    }\n\n                    #say STDERR \"Total literals length: \", $literals_length;\n\n                    my $literals = '';\n\n                    if ($literals_length > 0) {\n                        $literals = substr($compressed, 0, $literals_length, '');\n                    }\n\n                    if ($compressed eq '') {    # end of block\n                        $decoded .= $literals;\n                        last;\n                    }\n\n                    my $offset = oct('0b' . reverse unpack('b16', substr($compressed, 0, 2, '')));\n\n                    if ($offset == 0) {\n                        die \"Corrupted block\";\n                    }\n\n                    # say STDERR \"Offset: $offset\";\n\n                    if ($match_len == 15) {\n                        while (1) {\n                            my $byte_len = ord(substr($compressed, 0, 1, ''));\n                            $match_len += $byte_len;\n                            last if $byte_len != 255;\n                        }\n                    }\n\n                    $decoded .= $literals;\n                    $match_len += 4;\n\n                    # say STDERR \"Total match len: $match_len\\n\";\n\n                    if ($offset >= $match_len) {    # non-overlapping matches\n                        $decoded .= substr($decoded, length($decoded) - $offset, $match_len);\n                    }\n                    elsif ($offset == 1) {\n                        $decoded .= substr($decoded, -1) x $match_len;\n                    }\n                    else {                          # overlapping matches\n                        foreach my $i (1 .. $match_len) {\n                            $decoded .= substr($decoded, length($decoded) - $offset, 1);\n                        }\n                    }\n                }\n            }\n\n            if ($B_checksum) {\n                my $content_checksum = bytes2int_lsb($fh, 4);\n                say STDERR \"Block checksum: $content_checksum\";\n            }\n\n            if ($B_indep) {    # blocks are independent of each other\n                print $out_fh $decoded;\n                $decoded = '';\n            }\n            elsif (length($decoded) > 2**16) {    # blocks are dependent\n                print $out_fh substr($decoded, 0, -(2**16), '');\n            }\n        }\n\n        if ($C_checksum) {\n            my $content_checksum = bytes2int_lsb($fh, 4);\n            say STDERR \"Content checksum: $content_checksum\";\n        }\n\n        print $out_fh $decoded;\n    }\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        open my $in_fh, '<:raw', $input\n          or die \"Can't open file <<$input>> for reading: $!\";\n\n        open my $out_fh, '>:raw', $output\n          or die \"Can't open file <<$output>> for writing: $!\";\n\n        my_lz4_decompress($in_fh, $out_fh)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n\n        open my $in_fh, '<:raw', $input\n          or die \"Can't open file <<$input>> for reading: $!\";\n\n        open my $out_fh, '>:raw', $output\n          or die \"Can't open file <<$output>> for writing: $!\";\n\n        my_lz4_compress($in_fh, $out_fh)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lz77_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\n\nuse constant {\n              PKGNAME    => 'LZ77',\n              VERSION    => '0.02',\n              FORMAT     => 'lz77',\n              CHUNK_SIZE => 1 << 16,\n             };\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(2);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub compression ($str) {\n\n    my @rep;\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = 0;\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n < 255\n               and $la + $n <= $end\n               and ($tmp = index($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        --$n;\n        push(@rep, $p, $n, $chars[$la + $n]);\n        $la += $n + 1;\n        $prefix .= $token;\n    }\n\n    pack('(SCa)*', @rep);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh compression($chunk);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    my $chunk = '';\n    while (read($fh, (my $str), 4 * CHUNK_SIZE)) {\n        my @decoded = unpack('(SCa)*', $str);\n\n        while (@decoded) {\n            my ($s, $l, $c) = splice(@decoded, 0, 3);\n\n            $chunk .= substr($chunk, $s, $l) . $c;\n\n            if (length($chunk) >= CHUNK_SIZE) {\n                print $out_fh $chunk;\n                $chunk = '';\n            }\n        }\n    }\n\n    print $out_fh $chunk;\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lza_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# Edit: 19 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + Arithmetic Coding (in fixed bits).\n\n# Reference:\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max);\n\nuse constant {\n              PKGNAME    => 'LZA',\n              VERSION    => '0.01',\n              FORMAT     => 'lza',\n              CHUNK_SIZE => 1 << 16,\n             };\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\n# Arithmetic Coding settings\nuse constant BITS => 32;\nuse constant MAX  => oct('0b' . ('1' x BITS));\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = 0;\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n < 255\n               and $la + $n <= $end\n               and ($tmp = index($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        --$n;\n        push @$indices,      $p;\n        push @$lengths,      $n;\n        push @$uncompressed, $chars[$la + $n];\n        $la += $n + 1;\n        $prefix .= $token;\n    }\n\n    return;\n}\n\nsub lz77_decompression ($uncompressed, $indices, $lengths) {\n\n    my $ret   = '';\n    my $chunk = '';\n\n    foreach my $i (0 .. $#{$uncompressed}) {\n        $chunk .= substr($chunk, $indices->[$i], $lengths->[$i]) . chr($uncompressed->[$i]);\n        if (length($chunk) >= CHUNK_SIZE) {\n            $ret .= $chunk;\n            $chunk = '';\n        }\n    }\n\n    if ($chunk ne '') {\n        $ret .= $chunk;\n    }\n\n    $ret;\n}\n\nsub create_cfreq ($freq) {\n\n    my @cf;\n    my $T = 0;\n\n    foreach my $i (sort { $a <=> $b } keys %$freq) {\n        $freq->{$i} // next;\n        $cf[$i] = $T;\n        $T += $freq->{$i};\n        $cf[$i + 1] = $T;\n    }\n\n    return (\\@cf, $T);\n}\n\nsub ac_encode ($bytes_arr) {\n\n    my $enc        = '';\n    my $EOF_SYMBOL = (max(@$bytes_arr) // 0) + 1;\n    my @bytes      = (@$bytes_arr, $EOF_SYMBOL);\n\n    my %freq;\n    ++$freq{$_} for @bytes;\n\n    my ($cf, $T) = create_cfreq(\\%freq);\n\n    if ($T > MAX) {\n        die \"Too few bits: $T > ${\\MAX}\";\n    }\n\n    my $low      = 0;\n    my $high     = MAX;\n    my $uf_count = 0;\n\n    foreach my $c (@bytes) {\n\n        my $w = $high - $low + 1;\n\n        $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$c]) / $T)) & MAX;\n\n        if ($high > MAX) {\n            die \"high > MAX: $high > ${\\MAX}\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n\n                my $bit = $high >> (BITS - 1);\n                $enc .= $bit;\n\n                if ($uf_count > 0) {\n                    $enc .= join('', 1 - $bit) x $uf_count;\n                    $uf_count = 0;\n                }\n\n                $low <<= 1;\n                ($high <<= 1) |= 1;\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                ++$uf_count;\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n        }\n    }\n\n    $enc .= '0';\n    $enc .= '1';\n\n    while (length($enc) % 8 != 0) {\n        $enc .= '1';\n    }\n\n    return ($enc, \\%freq);\n}\n\nsub ac_decode ($fh, $freq) {\n\n    my ($cf, $T) = create_cfreq($freq);\n\n    my @dec;\n    my $low  = 0;\n    my $high = MAX;\n    my $enc  = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS);\n\n    my @table;\n    foreach my $i (sort { $a <=> $b } keys %$freq) {\n        foreach my $j ($cf->[$i] .. $cf->[$i + 1] - 1) {\n            $table[$j] = $i;\n        }\n    }\n\n    my $EOF_SYMBOL = max(keys %$freq) // 0;\n\n    while (1) {\n\n        my $w  = $high - $low + 1;\n        my $ss = int((($T * ($enc - $low + 1)) - 1) / $w);\n\n        my $i = $table[$ss] // last;\n        last if ($i == $EOF_SYMBOL);\n\n        push @dec, $i;\n\n        $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$i]) / $T)) & MAX;\n\n        if ($high > MAX) {\n            die \"error\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n                ($high <<= 1) |= 1;\n                $low <<= 1;\n                ($enc <<= 1) |= (getc($fh) // 1);\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1);\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n            $enc  &= MAX;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub create_ac_entry ($bytes, $out_fh) {\n\n    my ($enc, $freq) = ac_encode($bytes);\n    my $max_symbol = max(keys %$freq) // 0;\n\n    my @freqs;\n    foreach my $k (0 .. $max_symbol) {\n        push @freqs, $freq->{$k} // 0;\n    }\n\n    push @freqs, length($enc) >> 3;\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_ac_entry ($fh) {\n\n    my @freqs    = @{delta_decode($fh)};\n    my $bits_len = pop(@freqs);\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    say \"Encoded length: $bits_len\";\n    my $bits = read_bits($fh, $bits_len << 3);\n\n    if ($bits_len > 0) {\n        open my $bits_fh, '<:raw', \\$bits;\n        return ac_decode($bits_fh, \\%freq);\n    }\n\n    return [];\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    my (@uncompressed, @indices, @lengths);\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        lz77_compression($chunk, \\@uncompressed, \\@indices, \\@lengths);\n    }\n\n    @indices      = unpack('C*', pack('S*', @indices));\n    @uncompressed = unpack('C*', join('', @uncompressed));\n\n    create_ac_entry(\\@uncompressed, $out_fh);\n    create_ac_entry(\\@indices,      $out_fh);\n    create_ac_entry(\\@lengths,      $out_fh);\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    my $uncompressed = decode_ac_entry($fh);\n    my @indices      = unpack('S*', pack('C*', @{decode_ac_entry($fh)}));\n    my $lengths      = decode_ac_entry($fh);\n\n    print $out_fh lz77_decompression($uncompressed, \\@indices, $lengths);\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzac_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# Edit: 06 February 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + Arithmetic Coding (in fixed bits).\n\n# Encoding the distances/indices using a DEFLATE-like approach.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n#\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max sum);\n\nuse constant {\n    PKGNAME => 'LZAC',\n    VERSION => '0.02',\n    FORMAT  => 'lzac',\n\n    CHUNK_SIZE => 1 << 16,    # higher value = better compression\n};\n\n# Arithmetic Coding settings\nuse constant BITS => 32;\nuse constant MAX  => oct('0b' . ('1' x BITS));\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(2);\n\n# [distance value, offset bits]\nmy @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4);\n\nuntil ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) {\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n}\n\nmy @DISTANCE_INDICES;\n\nforeach my $i (0 .. $#DISTANCE_SYMBOLS) {\n    my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        last if ($k > CHUNK_SIZE);\n        $DISTANCE_INDICES[$k] = $i;\n    }\n}\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n < 255\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        --$n;\n        push @$indices,      $la - $p;\n        push @$lengths,      $n;\n        push @$uncompressed, ord($chars[$la + $n]);\n        $la += $n + 1;\n        $prefix .= $token;\n    }\n\n    return;\n}\n\nsub lz77_decompression ($uncompressed, $indices, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#{$uncompressed}) {\n        $chunk .= substr($chunk, $offset - $indices->[$i], $lengths->[$i]) . chr($uncompressed->[$i]);\n        $offset += $lengths->[$i] + 1;\n    }\n\n    return $chunk;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub create_cfreq ($freq) {\n\n    my @cf;\n    my $T = 0;\n\n    foreach my $i (sort { $a <=> $b } keys %$freq) {\n        $freq->{$i} // next;\n        $cf[$i] = $T;\n        $T += $freq->{$i};\n        $cf[$i + 1] = $T;\n    }\n\n    return (\\@cf, $T);\n}\n\nsub ac_encode ($bytes_arr) {\n\n    my $enc        = '';\n    my $EOF_SYMBOL = (max(@$bytes_arr) // 0) + 1;\n    my @bytes      = (@$bytes_arr, $EOF_SYMBOL);\n\n    my %freq;\n    ++$freq{$_} for @bytes;\n\n    my ($cf, $T) = create_cfreq(\\%freq);\n\n    if ($T > MAX) {\n        die \"Too few bits: $T > ${\\MAX}\";\n    }\n\n    my $low      = 0;\n    my $high     = MAX;\n    my $uf_count = 0;\n\n    foreach my $c (@bytes) {\n\n        my $w = $high - $low + 1;\n\n        $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$c]) / $T)) & MAX;\n\n        if ($high > MAX) {\n            die \"high > MAX: $high > ${\\MAX}\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n\n                my $bit = $high >> (BITS - 1);\n                $enc .= $bit;\n\n                if ($uf_count > 0) {\n                    $enc .= join('', 1 - $bit) x $uf_count;\n                    $uf_count = 0;\n                }\n\n                $low <<= 1;\n                ($high <<= 1) |= 1;\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                ++$uf_count;\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n        }\n    }\n\n    $enc .= '0';\n    $enc .= '1';\n\n    while (length($enc) % 8 != 0) {\n        $enc .= '1';\n    }\n\n    return ($enc, \\%freq);\n}\n\nsub ac_decode ($fh, $freq) {\n\n    my ($cf, $T) = create_cfreq($freq);\n\n    my @dec;\n    my $low  = 0;\n    my $high = MAX;\n    my $enc  = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS);\n\n    my @table;\n    foreach my $i (sort { $a <=> $b } keys %$freq) {\n        foreach my $j ($cf->[$i] .. $cf->[$i + 1] - 1) {\n            $table[$j] = $i;\n        }\n    }\n\n    my $EOF_SYMBOL = max(keys %$freq) // 0;\n\n    while (1) {\n\n        my $w  = $high - $low + 1;\n        my $ss = int((($T * ($enc - $low + 1)) - 1) / $w);\n\n        my $i = $table[$ss] // last;\n        last if ($i == $EOF_SYMBOL);\n\n        push @dec, $i;\n\n        $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$i]) / $T)) & MAX;\n\n        if ($high > MAX) {\n            die \"error\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n                ($high <<= 1) |= 1;\n                $low <<= 1;\n                ($enc <<= 1) |= (getc($fh) // 1);\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1);\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n            $enc  &= MAX;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub create_ac_entry ($bytes, $out_fh) {\n\n    my ($enc, $freq) = ac_encode($bytes);\n    my $max_symbol = max(keys %$freq) // 0;\n\n    my @freqs;\n    foreach my $k (0 .. $max_symbol) {\n        push @freqs, $freq->{$k} // 0;\n    }\n\n    push @freqs, length($enc) >> 3;\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_ac_entry ($fh) {\n\n    my @freqs    = @{delta_decode($fh)};\n    my $bits_len = pop(@freqs);\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    say \"Encoded length: $bits_len\";\n    my $bits = read_bits($fh, $bits_len << 3);\n\n    if ($bits_len > 0) {\n        open my $bits_fh, '<:raw', \\$bits;\n        return ac_decode($bits_fh, \\%freq);\n    }\n\n    return [];\n}\n\nsub encode_distances ($distances, $out_fh) {\n\n    my @symbols;\n    my $offset_bits = '';\n\n    foreach my $dist (@$distances) {\n\n        my $i = $DISTANCE_INDICES[$dist];\n        my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n\n        push @symbols, $i;\n\n        if ($bits > 0) {\n            $offset_bits .= sprintf('%0*b', $bits, $dist - $min);\n        }\n    }\n\n    create_ac_entry(\\@symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n}\n\nsub decode_distances ($fh) {\n\n    my $symbols  = decode_ac_entry($fh);\n    my $bits_len = 0;\n\n    foreach my $i (@$symbols) {\n        $bits_len += $DISTANCE_SYMBOLS[$i][1];\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @distances;\n    foreach my $i (@$symbols) {\n        push @distances, $DISTANCE_SYMBOLS[$i][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$i][1], ''));\n    }\n\n    return \\@distances;\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my (@uncompressed, @indices, @lengths);\n        lz77_compression($chunk, \\@uncompressed, \\@indices, \\@lengths);\n\n        my $est_ratio = length($chunk) / (4 * scalar(@uncompressed));\n\n        say(scalar(@uncompressed), ' -> ', $est_ratio);\n\n        create_ac_entry(\\@uncompressed, $out_fh);\n        create_ac_entry(\\@lengths,      $out_fh);\n        encode_distances(\\@indices, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my $uncompressed = decode_ac_entry($fh);\n        my $lengths      = decode_ac_entry($fh);\n        my $indices      = decode_distances($fh);\n\n        print $out_fh lz77_decompression($uncompressed, $indices, $lengths);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzaz_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# Edit: 12 August 2023\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + Arithmetic Coding (with big-integers).\n\n# Encoding the distances/indices using a DEFLATE-like approach.\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max sum);\nuse Math::GMPz;\n\nuse constant {\n    PKGNAME => 'LZAZ',\n    VERSION => '0.01',\n    FORMAT  => 'lzaz',\n\n    CHUNK_SIZE => 1 << 16,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\n# [distance value, offset bits]\nmy @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4);\n\nuntil ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) {\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n}\n\nmy @DISTANCE_INDICES;\n\nforeach my $i (0 .. $#DISTANCE_SYMBOLS) {\n    my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        last if ($k > CHUNK_SIZE);\n        $DISTANCE_INDICES[$k] = $i;\n    }\n}\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n < 255\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        --$n;\n        push @$indices,      $la - $p;\n        push @$lengths,      $n;\n        push @$uncompressed, ord($chars[$la + $n]);\n        $la += $n + 1;\n        $prefix .= $token;\n    }\n\n    return;\n}\n\nsub lz77_decompression ($uncompressed, $indices, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#{$uncompressed}) {\n        $chunk .= substr($chunk, $offset - $indices->[$i], $lengths->[$i]) . chr($uncompressed->[$i]);\n        $offset += $lengths->[$i] + 1;\n    }\n\n    return $chunk;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub cumulative_freq ($freq) {\n\n    my %cf;\n    my $total = 0;\n    foreach my $c (sort { $a <=> $b } keys %$freq) {\n        $cf{$c} = $total;\n        $total += $freq->{$c};\n    }\n\n    return %cf;\n}\n\nsub ac_encode ($bytes_arr) {\n\n    my @chars = @$bytes_arr;\n\n    # The frequency characters\n    my %freq;\n    ++$freq{$_} for @chars;\n\n    # Create the cumulative frequency table\n    my %cf = cumulative_freq(\\%freq);\n\n    # Limit and base\n    my $base = Math::GMPz->new(scalar @chars);\n\n    # Lower bound\n    my $L = Math::GMPz->new(0);\n\n    # Product of all frequencies\n    my $pf = Math::GMPz->new(1);\n\n    # Each term is multiplied by the product of the\n    # frequencies of all previously occurring symbols\n    foreach my $c (@chars) {\n        Math::GMPz::Rmpz_mul($L, $L, $base);\n        Math::GMPz::Rmpz_addmul_ui($L, $pf, $cf{$c});\n        Math::GMPz::Rmpz_mul_ui($pf, $pf, $freq{$c});\n    }\n\n    # Upper bound\n    Math::GMPz::Rmpz_add($L, $L, $pf);\n\n    # Compute the power for left shift\n    my $pow = Math::GMPz::Rmpz_sizeinbase($pf, 2) - 1;\n\n    # Set $enc to (U-1) divided by 2^pow\n    Math::GMPz::Rmpz_sub_ui($L, $L, 1);\n    Math::GMPz::Rmpz_div_2exp($L, $L, $pow);\n\n    # Remove any divisibility by 2\n    if ($L > 0 and Math::GMPz::Rmpz_even_p($L)) {\n        $pow += Math::GMPz::Rmpz_remove($L, $L, Math::GMPz->new(2));\n    }\n\n    my $bin = Math::GMPz::Rmpz_get_str($L, 2);\n\n    return ($bin, $pow, \\%freq);\n}\n\nsub ac_decode ($bits, $pow2, $freq) {\n\n    # Decode the bits into an integer\n    my $enc = Math::GMPz->new($bits, 2);\n    Math::GMPz::Rmpz_mul_2exp($enc, $enc, $pow2);\n\n    my $base = sum(values %$freq) // 0;\n\n    if ($base == 0) {\n        return [];\n    }\n    elsif ($base == 1) {\n        return [keys %$freq];\n    }\n\n    # Create the cumulative frequency table\n    my %cf = cumulative_freq($freq);\n\n    # Create the dictionary\n    my %dict;\n    while (my ($k, $v) = each %cf) {\n        $dict{$v} = $k;\n    }\n\n    # Fill the gaps in the dictionary\n    my $lchar;\n    foreach my $i (0 .. $base - 1) {\n        if (exists $dict{$i}) {\n            $lchar = $dict{$i};\n        }\n        elsif (defined $lchar) {\n            $dict{$i} = $lchar;\n        }\n    }\n\n    my $div = Math::GMPz::Rmpz_init();\n\n    my @dec;\n\n    # Decode the input number\n    for (my $pow = Math::GMPz->new($base)**($base - 1) ; Math::GMPz::Rmpz_sgn($pow) > 0 ; Math::GMPz::Rmpz_tdiv_q_ui($pow, $pow, $base)) {\n\n        Math::GMPz::Rmpz_tdiv_q($div, $enc, $pow);\n\n        my $c  = $dict{$div};\n        my $fv = $freq->{$c};\n        my $cv = $cf{$c};\n\n        Math::GMPz::Rmpz_submul_ui($enc, $pow, $cv);\n        Math::GMPz::Rmpz_tdiv_q_ui($enc, $enc, $fv);\n\n        push @dec, $c;\n    }\n\n    return \\@dec;\n}\n\nsub create_ac_entry ($bytes, $out_fh) {\n\n    my ($enc, $pow, $freq) = ac_encode($bytes);\n\n    my @freqs;\n    my $max_symbol = max(keys %$freq) // 0;\n\n    foreach my $k (0 .. $max_symbol) {\n        push @freqs, $freq->{$k} // 0;\n    }\n\n    push @freqs, $pow;\n    push @freqs, length($enc);\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_ac_entry ($fh) {\n\n    my @freqs    = @{delta_decode($fh)};\n    my $bits_len = pop(@freqs);\n    my $pow2     = pop(@freqs);\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    if ($bits_len > 0) {\n        return ac_decode($bits, $pow2, \\%freq);\n    }\n\n    return [];\n}\n\nsub encode_distances ($distances, $out_fh) {\n\n    my @symbols;\n    my $offset_bits = '';\n\n    foreach my $dist (@$distances) {\n\n        my $i = $DISTANCE_INDICES[$dist];\n        my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n\n        push @symbols, $i;\n\n        if ($bits > 0) {\n            $offset_bits .= sprintf('%0*b', $bits, $dist - $min);\n        }\n    }\n\n    create_ac_entry(\\@symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n}\n\nsub decode_distances ($fh) {\n\n    my $symbols  = decode_ac_entry($fh);\n    my $bits_len = 0;\n\n    foreach my $i (@$symbols) {\n        $bits_len += $DISTANCE_SYMBOLS[$i][1];\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @distances;\n    foreach my $i (@$symbols) {\n        push @distances, $DISTANCE_SYMBOLS[$i][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$i][1], ''));\n    }\n\n    return \\@distances;\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my (@uncompressed, @indices, @lengths);\n        lz77_compression($chunk, \\@uncompressed, \\@indices, \\@lengths);\n\n        my $est_ratio = length($chunk) / (4 * scalar(@uncompressed));\n\n        say(scalar(@uncompressed), ' -> ', $est_ratio);\n\n        create_ac_entry(\\@uncompressed, $out_fh);\n        create_ac_entry(\\@lengths,      $out_fh);\n        encode_distances(\\@indices, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my $uncompressed = decode_ac_entry($fh);\n        my $lengths      = decode_ac_entry($fh);\n        my $indices      = decode_distances($fh);\n\n        print $out_fh lz77_decompression($uncompressed, $indices, $lengths);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzb2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 11 May 2024\n# Edit: 02 June 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression (LZSS variant with hash tables), using a byte-aligned encoding, similar to LZ4.\n\n# References:\n#   https://github.com/lz4/lz4/blob/dev/doc/lz4_Frame_format.md\n#   https://github.com/lz4/lz4/blob/dev/doc/lz4_Block_format.md\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\n\nuse constant {\n    PKGNAME => 'LZB2',\n    VERSION => '0.01',\n    FORMAT  => 'lzb2',\n\n    MIN_MATCH_LEN  => 4,                # minimum match length\n    MAX_MATCH_LEN  => ~0,               # maximum match length\n    MAX_MATCH_DIST => (1 << 16) - 1,    # maximum match distance\n    MAX_CHAIN_LEN  => 48,               # higher value = better compression\n\n    CHUNK_SIZE => 1 << 18,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lzss_encode($str) {\n\n    my $la = 0;\n\n    my @symbols = unpack('C*', $str);\n    my $end     = $#symbols;\n\n    my $min_len       = MIN_MATCH_LEN;     # minimum match length\n    my $max_len       = MAX_MATCH_LEN;     # maximum match length\n    my $max_dist      = MAX_MATCH_DIST;    # maximum match distance\n    my $max_chain_len = MAX_CHAIN_LEN;     # how many recent positions to keep track of\n\n    my (@literals, @distances, @lengths, %table);\n\n    while ($la <= $end) {\n\n        my $best_n = 1;\n        my $best_p = $la;\n\n        my $lookahead = substr($str, $la, $min_len);\n\n        if (exists($table{$lookahead})) {\n\n            foreach my $p (@{$table{$lookahead}}) {\n\n                last if ($la - $p > $max_dist);\n\n                my $n = $min_len;\n\n                while ($n <= $max_len and $la + $n <= $end and $symbols[$la + $n - 1] == $symbols[$p + $n - 1]) {\n                    ++$n;\n                }\n\n                if ($n > $best_n) {\n                    $best_p = $p;\n                    $best_n = $n;\n                }\n            }\n\n            my $matched = substr($str, $la, $best_n);\n\n            foreach my $i (0 .. length($matched) - $min_len) {\n\n                my $key = substr($matched, $i, $min_len);\n                unshift @{$table{$key}}, $la + $i;\n\n                if (scalar(@{$table{$key}}) > $max_chain_len) {\n                    pop @{$table{$key}};\n                }\n            }\n        }\n\n        if ($best_n == 1) {\n            $table{$lookahead} = [$la];\n        }\n\n        if ($best_n > $min_len) {\n\n            push @lengths,   $best_n - 1;\n            push @distances, $la - $best_p;\n            push @literals,  undef;\n\n            $la += $best_n - 1;\n        }\n        else {\n\n            push @lengths,   (0) x $best_n;\n            push @distances, (0) x $best_n;\n            push @literals, @symbols[$best_p .. $best_p + $best_n - 1];\n\n            $la += $best_n;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\nsub compression($chunk, $out_fh) {\n    my ($literals, $distances, $lengths) = lzss_encode($chunk);\n\n    my $literals_end = $#{$literals};\n\n    for (my $i = 0 ; $i <= $literals_end ; ++$i) {\n\n        my @uncompressed;\n        while ($i <= $literals_end and defined($literals->[$i])) {\n            push @uncompressed, $literals->[$i];\n            ++$i;\n        }\n\n        my $literals_string = pack('C*', @uncompressed);\n        my $literals_length = scalar(@uncompressed);\n\n        my $dist      = $distances->[$i] // 0;\n        my $match_len = $lengths->[$i]   // 0;\n\n        my $len_byte = 0;\n\n        $len_byte |= ($literals_length >= 7 ? 7  : $literals_length) << 5;\n        $len_byte |= ($match_len >= 31      ? 31 : $match_len);\n\n        $literals_length -= 7;\n        $match_len       -= 31;\n\n        print $out_fh chr($len_byte);\n\n        while ($literals_length >= 0) {\n            print $out_fh chr($literals_length >= 255 ? 255 : $literals_length);\n            $literals_length -= 255;\n        }\n\n        print $out_fh $literals_string;\n\n        while ($match_len >= 0) {\n            print $out_fh chr($match_len >= 255 ? 255 : $match_len);\n            $match_len -= 255;\n        }\n\n        if ($dist >= 1 << 16) {\n            die \"Too large distance: $dist\";\n        }\n\n        print $out_fh pack('B*', sprintf('%016b', $dist));\n    }\n\n}\n\nsub decompression($fh, $out_fh) {\n\n    my $search_window = '';\n\n    while (!eof($fh)) {\n\n        my $len_byte = ord(getc($fh));\n\n        my $literals_length = $len_byte >> 5;\n        my $match_len       = $len_byte & 0b11111;\n\n        if ($literals_length == 7) {\n            while (1) {\n                my $byte_len = ord(getc($fh));\n                $literals_length += $byte_len;\n                last if $byte_len != 255;\n            }\n        }\n\n        my $literals = '';\n        if ($literals_length > 0) {\n            read($fh, $literals, $literals_length);\n        }\n\n        if ($match_len == 31) {\n            while (1) {\n                my $byte_len = ord(getc($fh));\n                $match_len += $byte_len;\n                last if $byte_len != 255;\n            }\n        }\n\n        my $offset = oct('0b' . unpack('B*', getc($fh) . getc($fh)));\n\n        $search_window .= $literals;\n\n        if ($offset == 1) {\n            $search_window .= substr($search_window, -1) x $match_len;\n        }\n        elsif ($offset >= $match_len) {    # non-overlapping matches\n            $search_window .= substr($search_window, length($search_window) - $offset, $match_len);\n        }\n        else {                             # overlapping matches\n            foreach my $i (1 .. $match_len) {\n                $search_window .= substr($search_window, length($search_window) - $offset, 1);\n            }\n        }\n\n        print $out_fh substr($search_window, -($match_len + $literals_length));\n        $search_window = substr($search_window, -MAX_MATCH_DIST) if (length($search_window) > 2 * MAX_MATCH_DIST);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzb_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 11 May 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression (LZSS variant with hash tables), using a byte-aligned encoding, similar to LZ4.\n\n# References:\n#   https://github.com/lz4/lz4/blob/dev/doc/lz4_Frame_format.md\n#   https://github.com/lz4/lz4/blob/dev/doc/lz4_Block_format.md\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\n\nuse constant {\n    PKGNAME => 'LZB',\n    VERSION => '0.01',\n    FORMAT  => 'lzb',\n\n    MIN_MATCH_LEN  => 4,                # minimum match length\n    MAX_MATCH_LEN  => ~0,               # maximum match length\n    MAX_MATCH_DIST => (1 << 16) - 1,    # maximum match distance\n    MAX_CHAIN_LEN  => 48,               # higher value = better compression\n\n    CHUNK_SIZE => 1 << 18,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lzss_encode($str) {\n\n    my $la = 0;\n\n    my @symbols = unpack('C*', $str);\n    my $end     = $#symbols;\n\n    my $min_len       = MIN_MATCH_LEN;     # minimum match length\n    my $max_len       = MAX_MATCH_LEN;     # maximum match length\n    my $max_dist      = MAX_MATCH_DIST;    # maximum match distance\n    my $max_chain_len = MAX_CHAIN_LEN;     # how many recent positions to keep track of\n\n    my (@literals, @distances, @lengths, %table);\n\n    while ($la <= $end) {\n\n        my $best_n = 1;\n        my $best_p = $la;\n\n        my $lookahead = substr($str, $la, $min_len);\n\n        if (exists($table{$lookahead})) {\n\n            foreach my $p (@{$table{$lookahead}}) {\n\n                last if ($la - $p > $max_dist);\n\n                my $n = $min_len;\n\n                while ($n <= $max_len and $la + $n <= $end and $symbols[$la + $n - 1] == $symbols[$p + $n - 1]) {\n                    ++$n;\n                }\n\n                if ($n > $best_n) {\n                    $best_p = $p;\n                    $best_n = $n;\n                }\n            }\n\n            my $matched = substr($str, $la, $best_n);\n\n            foreach my $i (0 .. length($matched) - $min_len) {\n\n                my $key = substr($matched, $i, $min_len);\n                unshift @{$table{$key}}, $la + $i;\n\n                if (scalar(@{$table{$key}}) > $max_chain_len) {\n                    pop @{$table{$key}};\n                }\n            }\n        }\n\n        if ($best_n == 1) {\n            $table{$lookahead} = [$la];\n        }\n\n        if ($best_n > $min_len) {\n\n            push @lengths,   $best_n - 1;\n            push @distances, $la - $best_p;\n            push @literals,  undef;\n\n            $la += $best_n - 1;\n        }\n        else {\n\n            push @lengths,   (0) x $best_n;\n            push @distances, (0) x $best_n;\n            push @literals, @symbols[$best_p .. $best_p + $best_n - 1];\n\n            $la += $best_n;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\nsub compression($chunk, $out_fh) {\n    my ($literals, $distances, $lengths) = lzss_encode($chunk);\n\n    my $literals_end = $#{$literals};\n\n    for (my $i = 0 ; $i <= $literals_end ; ++$i) {\n\n        my @uncompressed;\n        while ($i <= $literals_end and defined($literals->[$i])) {\n            push @uncompressed, $literals->[$i];\n            ++$i;\n        }\n\n        my $literals_string = pack('C*', @uncompressed);\n        my $literals_length = scalar(@uncompressed);\n\n        my $dist      = $distances->[$i] // 0;\n        my $match_len = $lengths->[$i]   // 0;\n\n        my $len_byte = 0;\n\n        $len_byte |= ($literals_length >= 15 ? 15 : $literals_length) << 4;\n        $len_byte |= ($match_len >= 15       ? 15 : $match_len);\n\n        $literals_length -= 15;\n        $match_len       -= 15;\n\n        print $out_fh chr($len_byte);\n\n        while ($literals_length >= 0) {\n            print $out_fh chr($literals_length >= 255 ? 255 : $literals_length);\n            $literals_length -= 255;\n        }\n\n        print $out_fh $literals_string;\n\n        while ($match_len >= 0) {\n            print $out_fh chr($match_len >= 255 ? 255 : $match_len);\n            $match_len -= 255;\n        }\n\n        if ($dist >= 1 << 16) {\n            die \"Too large distance: $dist\";\n        }\n\n        print $out_fh pack('B*', sprintf('%016b', $dist));\n    }\n}\n\nsub decompression($fh, $out_fh) {\n\n    my $search_window = '';\n\n    while (!eof($fh)) {\n\n        my $len_byte = ord(getc($fh));\n\n        my $literals_length = $len_byte >> 4;\n        my $match_len       = $len_byte & 0b1111;\n\n        if ($literals_length == 15) {\n            while (1) {\n                my $byte_len = ord(getc($fh));\n                $literals_length += $byte_len;\n                last if $byte_len != 255;\n            }\n        }\n\n        my $literals = '';\n        if ($literals_length > 0) {\n            read($fh, $literals, $literals_length);\n        }\n\n        if ($match_len == 15) {\n            while (1) {\n                my $byte_len = ord(getc($fh));\n                $match_len += $byte_len;\n                last if $byte_len != 255;\n            }\n        }\n\n        my $offset = oct('0b' . unpack('B*', getc($fh) . getc($fh)));\n\n        $search_window .= $literals;\n\n        if ($offset == 1) {\n            $search_window .= substr($search_window, -1) x $match_len;\n        }\n        elsif ($offset >= $match_len) {    # non-overlapping matches\n            $search_window .= substr($search_window, length($search_window) - $offset, $match_len);\n        }\n        else {                             # overlapping matches\n            foreach my $i (1 .. $match_len) {\n                $search_window .= substr($search_window, length($search_window) - $offset, 1);\n            }\n        }\n\n        print $out_fh substr($search_window, -($match_len + $literals_length));\n        $search_window = substr($search_window, -MAX_MATCH_DIST) if (length($search_window) > 2 * MAX_MATCH_DIST);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzbf2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 11 May 2024\n# Edit: 02 June 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression (LZSS variant with hash tables), using a byte-aligned encoding, similar to LZ4.\n\n# References:\n#   https://github.com/lz4/lz4/blob/dev/doc/lz4_Frame_format.md\n#   https://github.com/lz4/lz4/blob/dev/doc/lz4_Block_format.md\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\n\nuse constant {\n    PKGNAME => 'LZBF2',\n    VERSION => '0.01',\n    FORMAT  => 'lzbf2',\n\n    MIN_MATCH_LEN  => 5,                # minimum match length\n    MAX_MATCH_LEN  => ~0,               # maximum match length\n    MAX_MATCH_DIST => (1 << 16) - 1,    # maximum match distance\n\n    CHUNK_SIZE => 1 << 18,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lzss_encode_fast($str) {\n\n    my $la = 0;\n\n    my @symbols = unpack('C*', $str);\n    my $end     = $#symbols;\n\n    my $min_len  = MIN_MATCH_LEN;     # minimum match length\n    my $max_len  = MAX_MATCH_LEN;     # maximum match length\n    my $max_dist = MAX_MATCH_DIST;    # maximum match distance\n\n    my (@literals, @distances, @lengths, %table);\n\n    while ($la <= $end) {\n\n        my $best_n = 1;\n        my $best_p = $la;\n\n        my $lookahead = substr($str, $la, $min_len);\n\n        if (exists($table{$lookahead}) and $la - $table{$lookahead} <= $max_dist) {\n\n            my $p = $table{$lookahead};\n            my $n = $min_len;\n\n            while ($n <= $max_len and $la + $n <= $end and $symbols[$la + $n - 1] == $symbols[$p + $n - 1]) {\n                ++$n;\n            }\n\n            $best_p = $p;\n            $best_n = $n;\n        }\n\n        $table{$lookahead} = $la;\n\n        if ($best_n > $min_len) {\n\n            push @lengths,   $best_n - 1;\n            push @distances, $la - $best_p;\n            push @literals,  undef;\n\n            $la += $best_n - 1;\n        }\n        else {\n\n            push @lengths,   (0) x $best_n;\n            push @distances, (0) x $best_n;\n            push @literals, @symbols[$best_p .. $best_p + $best_n - 1];\n\n            $la += $best_n;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\nsub compression($chunk, $out_fh) {\n    my ($literals, $distances, $lengths) = lzss_encode_fast($chunk);\n\n    my $literals_end = $#{$literals};\n\n    for (my $i = 0 ; $i <= $literals_end ; ++$i) {\n\n        my @uncompressed;\n        while ($i <= $literals_end and defined($literals->[$i])) {\n            push @uncompressed, $literals->[$i];\n            ++$i;\n        }\n\n        my $literals_string = pack('C*', @uncompressed);\n        my $literals_length = scalar(@uncompressed);\n\n        my $dist      = $distances->[$i] // 0;\n        my $match_len = $lengths->[$i]   // 0;\n\n        my $len_byte = 0;\n\n        $len_byte |= ($literals_length >= 7 ? 7  : $literals_length) << 5;\n        $len_byte |= ($match_len >= 31      ? 31 : $match_len);\n\n        $literals_length -= 7;\n        $match_len       -= 31;\n\n        print $out_fh chr($len_byte);\n\n        while ($literals_length >= 0) {\n            print $out_fh chr($literals_length >= 255 ? 255 : $literals_length);\n            $literals_length -= 255;\n        }\n\n        print $out_fh $literals_string;\n\n        while ($match_len >= 0) {\n            print $out_fh chr($match_len >= 255 ? 255 : $match_len);\n            $match_len -= 255;\n        }\n\n        if ($dist >= 1 << 16) {\n            die \"Too large distance: $dist\";\n        }\n\n        print $out_fh pack('B*', sprintf('%016b', $dist));\n    }\n\n}\n\nsub decompression($fh, $out_fh) {\n\n    my $search_window = '';\n\n    while (!eof($fh)) {\n\n        my $len_byte = ord(getc($fh));\n\n        my $literals_length = $len_byte >> 5;\n        my $match_len       = $len_byte & 0b11111;\n\n        if ($literals_length == 7) {\n            while (1) {\n                my $byte_len = ord(getc($fh));\n                $literals_length += $byte_len;\n                last if $byte_len != 255;\n            }\n        }\n\n        my $literals = '';\n        if ($literals_length > 0) {\n            read($fh, $literals, $literals_length);\n        }\n\n        if ($match_len == 31) {\n            while (1) {\n                my $byte_len = ord(getc($fh));\n                $match_len += $byte_len;\n                last if $byte_len != 255;\n            }\n        }\n\n        my $offset = oct('0b' . unpack('B*', getc($fh) . getc($fh)));\n\n        $search_window .= $literals;\n\n        if ($offset == 1) {\n            $search_window .= substr($search_window, -1) x $match_len;\n        }\n        elsif ($offset >= $match_len) {    # non-overlapping matches\n            $search_window .= substr($search_window, length($search_window) - $offset, $match_len);\n        }\n        else {                             # overlapping matches\n            foreach my $i (1 .. $match_len) {\n                $search_window .= substr($search_window, length($search_window) - $offset, 1);\n            }\n        }\n\n        print $out_fh substr($search_window, -($match_len + $literals_length));\n        $search_window = substr($search_window, -MAX_MATCH_DIST) if (length($search_window) > 2 * MAX_MATCH_DIST);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzbf_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 11 May 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression (LZSS variant with hash tables), using a byte-aligned encoding, similar to LZ4.\n\n# References:\n#   https://github.com/lz4/lz4/blob/dev/doc/lz4_Frame_format.md\n#   https://github.com/lz4/lz4/blob/dev/doc/lz4_Block_format.md\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\n\nuse constant {\n    PKGNAME => 'LZBF',\n    VERSION => '0.01',\n    FORMAT  => 'lzbf',\n\n    MIN_MATCH_LEN  => 5,                # minimum match length\n    MAX_MATCH_LEN  => ~0,               # maximum match length\n    MAX_MATCH_DIST => (1 << 16) - 1,    # maximum match distance\n\n    CHUNK_SIZE => 1 << 18,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lzss_encode_fast($str) {\n\n    my $la = 0;\n\n    my @symbols = unpack('C*', $str);\n    my $end     = $#symbols;\n\n    my $min_len  = MIN_MATCH_LEN;     # minimum match length\n    my $max_len  = MAX_MATCH_LEN;     # maximum match length\n    my $max_dist = MAX_MATCH_DIST;    # maximum match distance\n\n    my (@literals, @distances, @lengths, %table);\n\n    while ($la <= $end) {\n\n        my $best_n = 1;\n        my $best_p = $la;\n\n        my $lookahead = substr($str, $la, $min_len);\n\n        if (exists($table{$lookahead}) and $la - $table{$lookahead} <= $max_dist) {\n\n            my $p = $table{$lookahead};\n            my $n = $min_len;\n\n            while ($n <= $max_len and $la + $n <= $end and $symbols[$la + $n - 1] == $symbols[$p + $n - 1]) {\n                ++$n;\n            }\n\n            $best_p = $p;\n            $best_n = $n;\n        }\n\n        $table{$lookahead} = $la;\n\n        if ($best_n > $min_len) {\n\n            push @lengths,   $best_n - 1;\n            push @distances, $la - $best_p;\n            push @literals,  undef;\n\n            $la += $best_n - 1;\n        }\n        else {\n\n            push @lengths,   (0) x $best_n;\n            push @distances, (0) x $best_n;\n            push @literals, @symbols[$best_p .. $best_p + $best_n - 1];\n\n            $la += $best_n;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\nsub compression($chunk, $out_fh) {\n    my ($literals, $distances, $lengths) = lzss_encode_fast($chunk);\n\n    my $literals_end = $#{$literals};\n\n    for (my $i = 0 ; $i <= $literals_end ; ++$i) {\n\n        my @uncompressed;\n        while ($i <= $literals_end and defined($literals->[$i])) {\n            push @uncompressed, $literals->[$i];\n            ++$i;\n        }\n\n        my $literals_string = pack('C*', @uncompressed);\n        my $literals_length = scalar(@uncompressed);\n\n        my $dist      = $distances->[$i] // 0;\n        my $match_len = $lengths->[$i]   // 0;\n\n        my $len_byte = 0;\n\n        $len_byte |= ($literals_length >= 15 ? 15 : $literals_length) << 4;\n        $len_byte |= ($match_len >= 15       ? 15 : $match_len);\n\n        $literals_length -= 15;\n        $match_len       -= 15;\n\n        print $out_fh chr($len_byte);\n\n        while ($literals_length >= 0) {\n            print $out_fh chr($literals_length >= 255 ? 255 : $literals_length);\n            $literals_length -= 255;\n        }\n\n        print $out_fh $literals_string;\n\n        while ($match_len >= 0) {\n            print $out_fh chr($match_len >= 255 ? 255 : $match_len);\n            $match_len -= 255;\n        }\n\n        if ($dist >= 1 << 16) {\n            die \"Too large distance: $dist\";\n        }\n\n        print $out_fh pack('B*', sprintf('%016b', $dist));\n    }\n\n}\n\nsub decompression($fh, $out_fh) {\n\n    my $search_window = '';\n\n    while (!eof($fh)) {\n\n        my $len_byte = ord(getc($fh));\n\n        my $literals_length = $len_byte >> 4;\n        my $match_len       = $len_byte & 0b1111;\n\n        if ($literals_length == 15) {\n            while (1) {\n                my $byte_len = ord(getc($fh));\n                $literals_length += $byte_len;\n                last if $byte_len != 255;\n            }\n        }\n\n        my $literals = '';\n        if ($literals_length > 0) {\n            read($fh, $literals, $literals_length);\n        }\n\n        if ($match_len == 15) {\n            while (1) {\n                my $byte_len = ord(getc($fh));\n                $match_len += $byte_len;\n                last if $byte_len != 255;\n            }\n        }\n\n        my $offset = oct('0b' . unpack('B*', getc($fh) . getc($fh)));\n\n        $search_window .= $literals;\n\n        if ($offset == 1) {\n            $search_window .= substr($search_window, -1) x $match_len;\n        }\n        elsif ($offset >= $match_len) {    # non-overlapping matches\n            $search_window .= substr($search_window, length($search_window) - $offset, $match_len);\n        }\n        else {                             # overlapping matches\n            foreach my $i (1 .. $match_len) {\n                $search_window .= substr($search_window, length($search_window) - $offset, 1);\n            }\n        }\n\n        print $out_fh substr($search_window, -($match_len + $literals_length));\n        $search_window = substr($search_window, -MAX_MATCH_DIST) if (length($search_window) > 2 * MAX_MATCH_DIST);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzbh_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 11 May 2024\n# Edit: 02 June 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression (LZSS variant with hash tables), inspired by LZ4, combined with Huffman coding.\n\n# References:\n#   https://github.com/lz4/lz4/blob/dev/doc/lz4_Frame_format.md\n#   https://github.com/lz4/lz4/blob/dev/doc/lz4_Block_format.md\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max);\n\nuse constant {\n    PKGNAME => 'LZBH',\n    VERSION => '0.01',\n    FORMAT  => 'lzbh',\n\n    MIN_MATCH_LEN  => 4,                # minimum match length\n    MAX_MATCH_LEN  => ~0,               # maximum match length\n    MAX_MATCH_DIST => (1 << 17) - 1,    # maximum match distance\n    MAX_CHAIN_LEN  => 48,               # higher value = better compression\n\n    CHUNK_SIZE => 1 << 18,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\n# [distance value, offset bits]\nmy @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4);\n\nuntil ($DISTANCE_SYMBOLS[-1][0] > MAX_MATCH_DIST) {\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n}\n\nmy @DISTANCE_INDICES;\n\nforeach my $i (0 .. $#DISTANCE_SYMBOLS) {\n    my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        last if ($k > MAX_MATCH_DIST);\n        $DISTANCE_INDICES[$k] = $i;\n    }\n}\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\nsub encode_distances ($distances, $out_fh) {\n\n    my @symbols;\n    my $offset_bits = '';\n\n    foreach my $dist (@$distances) {\n\n        my $i = $DISTANCE_INDICES[$dist];\n        my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n\n        push @symbols, $i;\n\n        if ($bits > 0) {\n            $offset_bits .= sprintf('%0*b', $bits, $dist - $min);\n        }\n    }\n\n    create_huffman_entry(\\@symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n}\n\nsub decode_distances ($fh) {\n\n    my $symbols  = decode_huffman_entry($fh);\n    my $bits_len = 0;\n\n    foreach my $i (@$symbols) {\n        $bits_len += $DISTANCE_SYMBOLS[$i][1];\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @distances;\n    foreach my $i (@$symbols) {\n        push @distances, $DISTANCE_SYMBOLS[$i][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$i][1], ''));\n    }\n\n    return \\@distances;\n}\n\nsub lzss_encode($str) {\n\n    my $la = 0;\n\n    my @symbols = unpack('C*', $str);\n    my $end     = $#symbols;\n\n    my $min_len       = MIN_MATCH_LEN;     # minimum match length\n    my $max_len       = MAX_MATCH_LEN;     # maximum match length\n    my $max_dist      = MAX_MATCH_DIST;    # maximum match distance\n    my $max_chain_len = MAX_CHAIN_LEN;     # how many recent positions to keep track of\n\n    my (@literals, @distances, @lengths, %table);\n\n    while ($la <= $end) {\n\n        my $best_n = 1;\n        my $best_p = $la;\n\n        my $lookahead = substr($str, $la, $min_len);\n\n        if (exists($table{$lookahead})) {\n\n            foreach my $p (@{$table{$lookahead}}) {\n\n                if ($la - $p > $max_dist) {\n                    last;\n                }\n\n                my $n = $min_len;\n\n                while ($n <= $max_len and $la + $n <= $end and $symbols[$la + $n - 1] == $symbols[$p + $n - 1]) {\n                    ++$n;\n                }\n\n                if ($n > $best_n) {\n                    $best_p = $p;\n                    $best_n = $n;\n                }\n            }\n\n            my $matched = substr($str, $la, $best_n);\n\n            foreach my $i (0 .. length($matched) - $min_len) {\n\n                my $key = substr($matched, $i, $min_len);\n                unshift @{$table{$key}}, $la + $i;\n\n                if (scalar(@{$table{$key}}) > $max_chain_len) {\n                    pop @{$table{$key}};\n                }\n            }\n        }\n\n        if ($best_n == 1) {\n            $table{$lookahead} = [$la];\n        }\n\n        if ($best_n > $min_len) {\n\n            push @lengths,   $best_n - 1;\n            push @distances, $la - $best_p;\n            push @literals,  undef;\n\n            $la += $best_n - 1;\n        }\n        else {\n\n            push @lengths,   (0) x $best_n;\n            push @distances, (0) x $best_n;\n            push @literals, @symbols[$best_p .. $best_p + $best_n - 1];\n\n            $la += $best_n;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\nsub lzbh_encode($chunk) {\n\n    my ($literals, $distances, $lengths) = lzss_encode($chunk);\n\n    my $literals_end = $#{$literals};\n    my (@symbols, @len_symbols, @match_symbols, @dist_symbols);\n\n    for (my $i = 0 ; $i <= $literals_end ; ++$i) {\n\n        my $j = $i;\n        while ($i <= $literals_end and defined($literals->[$i])) {\n            ++$i;\n        }\n\n        my $literals_length = $i - $j;\n        my $match_len       = $lengths->[$i] // 0;\n\n        push @match_symbols, (($literals_length >= 7 ? 7 : $literals_length) << 5) | ($match_len >= 31 ? 31 : $match_len);\n\n        $literals_length -= 7;\n        $match_len       -= 31;\n\n        while ($literals_length >= 0) {\n            push @len_symbols, ($literals_length >= 255 ? 255 : $literals_length);\n            $literals_length -= 255;\n        }\n\n        push @symbols, @{$literals}[$j .. $i - 1];\n\n        while ($match_len >= 0) {\n            push @match_symbols, ($match_len >= 255 ? 255 : $match_len);\n            $match_len -= 255;\n        }\n\n        push @dist_symbols, $distances->[$i] // 0;\n    }\n\n    return (\\@symbols, \\@len_symbols, \\@match_symbols, \\@dist_symbols);\n}\n\nsub lzbh_decode($symbols, $len_symbols, $match_symbols, $dist_symbols) {\n\n    my $data     = '';\n    my $data_len = 0;\n\n    my @symbols       = @$symbols;\n    my @len_symbols   = @$len_symbols;\n    my @match_symbols = @$match_symbols;\n    my @dist_symbols  = @$dist_symbols;\n\n    while (@symbols) {\n\n        my $len_byte = shift(@match_symbols);\n\n        my $literals_length = $len_byte >> 5;\n        my $match_len       = $len_byte & 0b11111;\n\n        if ($literals_length == 7) {\n            while (1) {\n                my $byte_len = shift(@len_symbols);\n                $literals_length += $byte_len;\n                last if $byte_len != 255;\n            }\n        }\n\n        if ($literals_length > 0) {\n            $data .= pack(\"C*\", splice(@symbols, 0, $literals_length));\n            $data_len += $literals_length;\n        }\n\n        if ($match_len == 31) {\n            while (1) {\n                my $byte_len = shift(@match_symbols);\n                $match_len += $byte_len;\n                last if $byte_len != 255;\n            }\n        }\n\n        my $dist = shift(@dist_symbols);\n\n        if ($dist == 1) {\n            $data .= substr($data, -1) x $match_len;\n        }\n        elsif ($dist >= $match_len) {\n            $data .= substr($data, $data_len - $dist, $match_len);\n        }\n        else {\n            foreach my $i (1 .. $match_len) {\n                $data .= substr($data, $data_len + $i - $dist - 1, 1);\n            }\n        }\n\n        $data_len += $match_len;\n    }\n\n    return $data;\n}\n\nsub compression($chunk, $out_fh) {\n    my ($symbols, $len_symbols, $match_symbols, $dist_symbols) = lzbh_encode($chunk);\n    create_huffman_entry($symbols,       $out_fh);\n    create_huffman_entry($len_symbols,   $out_fh);\n    create_huffman_entry($match_symbols, $out_fh);\n    encode_distances($dist_symbols, $out_fh);\n}\n\nsub decompression($fh, $out_fh) {\n\n    while (!eof($fh)) {\n\n        my $symbols       = decode_huffman_entry($fh);\n        my $len_symbols   = decode_huffman_entry($fh);\n        my $match_symbols = decode_huffman_entry($fh);\n        my $dist_symbols  = decode_distances($fh);\n\n        print $out_fh lzbh_decode($symbols, $len_symbols, $match_symbols, $dist_symbols);\n    }\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzbw_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 05 September 2023\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + fixed-width integers encoding + Burrows-Wheeler Transform (BWT) + Huffman coding.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\n\nuse constant {\n    PKGNAME => 'LZBW',\n    VERSION => '0.01',\n    FORMAT  => 'lzbw',\n\n    CHUNK_SIZE    => 1 << 16,    # higher value = better compression\n    LOOKAHEAD_LEN => 128,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n < 255\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        --$n;\n        push @$indices,      $la - $p;\n        push @$lengths,      $n;\n        push @$uncompressed, ord($chars[$la + $n]);\n        $la += $n + 1;\n        $prefix .= $token;\n    }\n\n    return;\n}\n\nsub lz77_decompression ($uncompressed, $indices, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#{$uncompressed}) {\n        $chunk .= substr($chunk, $offset - $indices->[$i], $lengths->[$i]) . $uncompressed->[$i];\n        $offset += $lengths->[$i] + 1;\n    }\n\n    return $chunk;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub encode_integers ($integers) {\n\n    my @counts;\n    my $count           = 0;\n    my $bits_width      = 1;\n    my $bits_max_symbol = 1 << $bits_width;\n    my $processed_len   = 0;\n\n    foreach my $k (@$integers) {\n        while ($k >= $bits_max_symbol) {\n\n            if ($count > 0) {\n                push @counts, [$bits_width, $count];\n                $processed_len += $count;\n            }\n\n            $count = 0;\n            $bits_max_symbol *= 2;\n            $bits_width      += 1;\n        }\n        ++$count;\n    }\n\n    push @counts, grep { $_->[1] > 0 } [$bits_width, scalar(@$integers) - $processed_len];\n\n    my $compressed = delta_encode([(map { $_->[0] } @counts), (map { $_->[1] } @counts)]);\n\n    my $bits = '';\n    foreach my $pair (@counts) {\n        my ($blen, $len) = @$pair;\n        foreach my $symbol (splice(@$integers, 0, $len)) {\n            $bits .= sprintf(\"%0*b\", $blen, $symbol);\n        }\n    }\n\n    $compressed .= pack('B*', $bits);\n    return $compressed;\n}\n\nsub decode_integers ($fh) {\n\n    my $ints = delta_decode($fh);\n    my $half = scalar(@$ints) >> 1;\n\n    my @counts;\n    foreach my $i (0 .. ($half - 1)) {\n        push @counts, [$ints->[$i], $ints->[$half + $i]];\n    }\n\n    my $bits_len = 0;\n\n    foreach my $pair (@counts) {\n        my ($blen, $len) = @$pair;\n        $bits_len += $blen * $len;\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @integers;\n    foreach my $pair (@counts) {\n        my ($blen, $len) = @$pair;\n        foreach my $chunk (unpack(sprintf('(a%d)*', $blen), substr($bits, 0, $blen * $len, ''))) {\n            push @integers, oct('0b' . $chunk);\n        }\n    }\n\n    return \\@integers;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n    say \"Max symbol: $max_symbol\\n\";\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    say \"Encoded length: $enc_len\\n\";\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        if ($enc == 0) {\n            $populated <<= 1;\n        }\n        else {\n            ($populated <<= 1) |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta);\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh))));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\nsub bz2_compression ($chunk, $out_fh) {\n\n    my $rle1 = rle4_encode([unpack('C*', $chunk)]);\n    my ($bwt, $idx) = bwt_encode(pack('C*', @$rle1));\n\n    say \"BWT index = $idx\";\n\n    my @bytes        = unpack('C*', $bwt);\n    my @alphabet     = sort { $a <=> $b } uniq(@bytes);\n    my $alphabet_enc = encode_alphabet(\\@alphabet);\n\n    my $mtf = mtf_encode(\\@bytes, [@alphabet]);\n    my $rle = rle_encode($mtf);\n\n    print $out_fh pack('N', $idx);\n    print $out_fh $alphabet_enc;\n    create_huffman_entry($rle, $out_fh);\n}\n\nsub bz2_decompression ($fh, $out_fh) {\n\n    my $idx      = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4));\n    my $alphabet = decode_alphabet($fh);\n\n    say \"BWT index = $idx\";\n    say \"Alphabet size: \", scalar(@$alphabet);\n\n    my $rle  = decode_huffman_entry($fh);\n    my $mtf  = rle_decode($rle);\n    my $bwt  = mtf_decode($mtf, $alphabet);\n    my $rle4 = bwt_decode(pack('C*', @$bwt), $idx);\n    my $data = rle4_decode([unpack('C*', $rle4)]);\n\n    print $out_fh pack('C*', @$data);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    my $lengths      = '';\n    my $uncompressed = '';\n\n    my @sizes;\n    my @indices_block;\n\n    open my $uc_fh,  '>:raw', \\$uncompressed;\n    open my $len_fh, '>:raw', \\$lengths;\n\n    my $create_bz2_block = sub {\n\n        scalar(@sizes) > 0 or return;\n\n        print $out_fh delta_encode(\\@sizes, 1);\n        my $indices = encode_integers(\\@indices_block);\n\n        bz2_compression($uncompressed, $out_fh);\n        bz2_compression($lengths,      $out_fh);\n        bz2_compression($indices,      $out_fh);\n\n        @sizes         = ();\n        @indices_block = ();\n\n        open $uc_fh,  '>:raw', \\$uncompressed;\n        open $len_fh, '>:raw', \\$lengths;\n    };\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my (@uncompressed, @indices, @lengths);\n        lz77_compression($chunk, \\@uncompressed, \\@indices, \\@lengths);\n\n        my $est_ratio = length($chunk) / (4 * scalar(@uncompressed));\n        say \"Est. ratio: \", $est_ratio, \" (\", scalar(@uncompressed), \" uncompressed bytes)\";\n\n        push @sizes, scalar(@uncompressed);\n        print $uc_fh pack('C*', @uncompressed);\n        print $len_fh pack('C*', @lengths);\n        push @indices_block, @indices;\n\n        if (length($uncompressed) >= CHUNK_SIZE) {\n            $create_bz2_block->();\n        }\n    }\n\n    $create_bz2_block->();\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my @sizes = @{delta_decode($fh, 1)};\n\n        my $indices      = '';\n        my $lengths      = '';\n        my $uncompressed = '';\n\n        open my $uc_fh,  '>:raw',  \\$uncompressed;\n        open my $len_fh, '>:raw',  \\$lengths;\n        open my $idx_fh, '+>:raw', \\$indices;\n\n        bz2_decompression($fh, $uc_fh);     # uncompressed\n        bz2_decompression($fh, $len_fh);    # lengths\n        bz2_decompression($fh, $idx_fh);    # indices\n\n        seek($idx_fh, 0, 0);\n\n        my @indices      = @{decode_integers($idx_fh)};\n        my @uncompressed = split(//, $uncompressed);\n        my @lengths      = unpack('C*', $lengths);\n\n        while (@uncompressed) {\n\n            my $size = shift(@sizes) // die \"decompression error\";\n\n            my @uncompressed_chunk = splice(@uncompressed, 0, $size);\n            my @lengths_chunk      = splice(@lengths,      0, $size);\n            my @indices_chunk      = splice(@indices,      0, $size);\n\n            scalar(@uncompressed_chunk) == $size or die \"decompression error\";\n            scalar(@lengths_chunk) == $size      or die \"decompression error\";\n            scalar(@indices_chunk) == $size      or die \"decompression error\";\n\n            print $out_fh lz77_decompression(\\@uncompressed_chunk, \\@indices_chunk, \\@lengths_chunk);\n        }\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzbwa_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 05 September 2023\n# Edit: 23 February 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + fixed-width integers encoding + Burrows-Wheeler Transform (BWT) + Arithmetic Coding.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n#\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\n\nuse constant {\n    PKGNAME => 'LZBWA',\n    VERSION => '0.01',\n    FORMAT  => 'lzbwa',\n\n    CHUNK_SIZE    => 1 << 16,    # higher value = better compression\n    LOOKAHEAD_LEN => 128,\n};\n\n# Arithmetic Coding settings\nuse constant BITS => 32;\nuse constant MAX  => oct('0b' . ('1' x BITS));\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n < 255\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        --$n;\n        push @$indices,      $la - $p;\n        push @$lengths,      $n;\n        push @$uncompressed, ord($chars[$la + $n]);\n        $la += $n + 1;\n        $prefix .= $token;\n    }\n\n    return;\n}\n\nsub lz77_decompression ($uncompressed, $indices, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#{$uncompressed}) {\n        $chunk .= substr($chunk, $offset - $indices->[$i], $lengths->[$i]) . $uncompressed->[$i];\n        $offset += $lengths->[$i] + 1;\n    }\n\n    return $chunk;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub encode_integers ($integers) {\n\n    my @counts;\n    my $count           = 0;\n    my $bits_width      = 1;\n    my $bits_max_symbol = 1 << $bits_width;\n    my $processed_len   = 0;\n\n    foreach my $k (@$integers) {\n        while ($k >= $bits_max_symbol) {\n\n            if ($count > 0) {\n                push @counts, [$bits_width, $count];\n                $processed_len += $count;\n            }\n\n            $count = 0;\n            $bits_max_symbol *= 2;\n            $bits_width      += 1;\n        }\n        ++$count;\n    }\n\n    push @counts, grep { $_->[1] > 0 } [$bits_width, scalar(@$integers) - $processed_len];\n\n    my $compressed = delta_encode([(map { $_->[0] } @counts), (map { $_->[1] } @counts)]);\n\n    my $bits = '';\n    foreach my $pair (@counts) {\n        my ($blen, $len) = @$pair;\n        foreach my $symbol (splice(@$integers, 0, $len)) {\n            $bits .= sprintf(\"%0*b\", $blen, $symbol);\n        }\n    }\n\n    $compressed .= pack('B*', $bits);\n    return $compressed;\n}\n\nsub decode_integers ($fh) {\n\n    my $ints = delta_decode($fh);\n    my $half = scalar(@$ints) >> 1;\n\n    my @counts;\n    foreach my $i (0 .. ($half - 1)) {\n        push @counts, [$ints->[$i], $ints->[$half + $i]];\n    }\n\n    my $bits_len = 0;\n\n    foreach my $pair (@counts) {\n        my ($blen, $len) = @$pair;\n        $bits_len += $blen * $len;\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @integers;\n    foreach my $pair (@counts) {\n        my ($blen, $len) = @$pair;\n        foreach my $chunk (unpack(sprintf('(a%d)*', $blen), substr($bits, 0, $blen * $len, ''))) {\n            push @integers, oct('0b' . $chunk);\n        }\n    }\n\n    return \\@integers;\n}\n\nsub create_cfreq ($freq) {\n\n    my @cf;\n    my $T = 0;\n\n    foreach my $i (sort { $a <=> $b } keys %$freq) {\n        $freq->{$i} // next;\n        $cf[$i] = $T;\n        $T += $freq->{$i};\n        $cf[$i + 1] = $T;\n    }\n\n    return (\\@cf, $T);\n}\n\nsub ac_encode ($bytes_arr) {\n\n    my $enc        = '';\n    my $EOF_SYMBOL = (max(@$bytes_arr) // 0) + 1;\n    my @bytes      = (@$bytes_arr, $EOF_SYMBOL);\n\n    my %freq;\n    ++$freq{$_} for @bytes;\n\n    my ($cf, $T) = create_cfreq(\\%freq);\n\n    if ($T > MAX) {\n        die \"Too few bits: $T > ${\\MAX}\";\n    }\n\n    my $low      = 0;\n    my $high     = MAX;\n    my $uf_count = 0;\n\n    foreach my $c (@bytes) {\n\n        my $w = $high - $low + 1;\n\n        $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$c]) / $T)) & MAX;\n\n        if ($high > MAX) {\n            die \"high > MAX: $high > ${\\MAX}\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n\n                my $bit = $high >> (BITS - 1);\n                $enc .= $bit;\n\n                if ($uf_count > 0) {\n                    $enc .= join('', 1 - $bit) x $uf_count;\n                    $uf_count = 0;\n                }\n\n                $low <<= 1;\n                ($high <<= 1) |= 1;\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                ++$uf_count;\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n        }\n    }\n\n    $enc .= '0';\n    $enc .= '1';\n\n    while (length($enc) % 8 != 0) {\n        $enc .= '1';\n    }\n\n    return ($enc, \\%freq);\n}\n\nsub ac_decode ($fh, $freq) {\n\n    my ($cf, $T) = create_cfreq($freq);\n\n    my @dec;\n    my $low  = 0;\n    my $high = MAX;\n    my $enc  = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS);\n\n    my @table;\n    foreach my $i (sort { $a <=> $b } keys %$freq) {\n        foreach my $j ($cf->[$i] .. $cf->[$i + 1] - 1) {\n            $table[$j] = $i;\n        }\n    }\n\n    my $EOF_SYMBOL = max(keys %$freq) // 0;\n\n    while (1) {\n\n        my $w  = $high - $low + 1;\n        my $ss = int((($T * ($enc - $low + 1)) - 1) / $w);\n\n        my $i = $table[$ss] // last;\n        last if ($i == $EOF_SYMBOL);\n\n        push @dec, $i;\n\n        $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$i]) / $T)) & MAX;\n\n        if ($high > MAX) {\n            die \"error\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n                ($high <<= 1) |= 1;\n                $low <<= 1;\n                ($enc <<= 1) |= (getc($fh) // 1);\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1);\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n            $enc  &= MAX;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub create_ac_entry ($bytes, $out_fh) {\n\n    my ($enc, $freq) = ac_encode($bytes);\n    my $max_symbol = max(keys %$freq) // 0;\n\n    my @freqs;\n    foreach my $k (0 .. $max_symbol) {\n        push @freqs, $freq->{$k} // 0;\n    }\n\n    push @freqs, length($enc) >> 3;\n\n    say \"Max symbol: $max_symbol\\n\";\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_ac_entry ($fh) {\n\n    my @freqs    = @{delta_decode($fh)};\n    my $bits_len = pop(@freqs);\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    say \"Encoded length: $bits_len\\n\";\n    my $bits = read_bits($fh, $bits_len << 3);\n\n    if ($bits_len > 0) {\n        open my $bits_fh, '<:raw', \\$bits;\n        return ac_decode($bits_fh, \\%freq);\n    }\n\n    return [];\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        if ($enc == 0) {\n            $populated <<= 1;\n        }\n        else {\n            ($populated <<= 1) |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta);\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh) // die \"error\")));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\nsub bz2_compression ($chunk, $out_fh) {\n\n    my $rle1 = rle4_encode([unpack('C*', $chunk)]);\n    my ($bwt, $idx) = bwt_encode(pack('C*', @$rle1));\n\n    say \"BWT index = $idx\";\n\n    my @bytes        = unpack('C*', $bwt);\n    my @alphabet     = sort { $a <=> $b } uniq(@bytes);\n    my $alphabet_enc = encode_alphabet(\\@alphabet);\n\n    my $mtf = mtf_encode(\\@bytes, [@alphabet]);\n    my $rle = rle_encode($mtf);\n\n    print $out_fh pack('N', $idx);\n    print $out_fh $alphabet_enc;\n    create_ac_entry($rle, $out_fh);\n}\n\nsub bz2_decompression ($fh, $out_fh) {\n\n    my $idx      = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4));\n    my $alphabet = decode_alphabet($fh);\n\n    say \"BWT index = $idx\";\n    say \"Alphabet size: \", scalar(@$alphabet);\n\n    my $rle  = decode_ac_entry($fh);\n    my $mtf  = rle_decode($rle);\n    my $bwt  = mtf_decode($mtf, $alphabet);\n    my $rle4 = bwt_decode(pack('C*', @$bwt), $idx);\n    my $data = rle4_decode([unpack('C*', $rle4)]);\n\n    print $out_fh pack('C*', @$data);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    my $lengths      = '';\n    my $uncompressed = '';\n\n    my @sizes;\n    my @indices_block;\n\n    open my $uc_fh,  '>:raw', \\$uncompressed;\n    open my $len_fh, '>:raw', \\$lengths;\n\n    my $create_bz2_block = sub {\n\n        scalar(@sizes) > 0 or return;\n\n        print $out_fh delta_encode(\\@sizes, 1);\n\n        my $indices = encode_integers(\\@indices_block);\n\n        bz2_compression($uncompressed, $out_fh);\n        bz2_compression($lengths,      $out_fh);\n        bz2_compression($indices,      $out_fh);\n\n        @sizes         = ();\n        @indices_block = ();\n\n        open $uc_fh,  '>:raw', \\$uncompressed;\n        open $len_fh, '>:raw', \\$lengths;\n    };\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my (@uncompressed, @indices, @lengths);\n        lz77_compression($chunk, \\@uncompressed, \\@indices, \\@lengths);\n\n        my $est_ratio = length($chunk) / (4 * scalar(@uncompressed));\n        say \"Est. ratio: \", $est_ratio, \" (\", scalar(@uncompressed), \" uncompressed bytes)\";\n\n        push @sizes, scalar(@uncompressed);\n        print $uc_fh pack('C*', @uncompressed);\n        print $len_fh pack('C*', @lengths);\n        push @indices_block, @indices;\n\n        if (length($uncompressed) >= CHUNK_SIZE) {\n            $create_bz2_block->();\n        }\n    }\n\n    $create_bz2_block->();\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my @sizes = @{delta_decode($fh, 1)};\n\n        my $indices      = '';\n        my $lengths      = '';\n        my $uncompressed = '';\n\n        open my $uc_fh,  '>:raw',  \\$uncompressed;\n        open my $len_fh, '>:raw',  \\$lengths;\n        open my $idx_fh, '+>:raw', \\$indices;\n\n        bz2_decompression($fh, $uc_fh);     # uncompressed\n        bz2_decompression($fh, $len_fh);    # lengths\n        bz2_decompression($fh, $idx_fh);    # indices\n\n        seek($idx_fh, 0, 0);\n\n        my @indices      = @{decode_integers($idx_fh)};\n        my @uncompressed = split(//, $uncompressed);\n        my @lengths      = unpack('C*', $lengths);\n\n        while (@uncompressed) {\n\n            my $size = shift(@sizes) // die \"decompression error\";\n\n            my @uncompressed_chunk = splice(@uncompressed, 0, $size);\n            my @lengths_chunk      = splice(@lengths,      0, $size);\n            my @indices_chunk      = splice(@indices,      0, $size);\n\n            scalar(@uncompressed_chunk) == $size or die \"decompression error\";\n            scalar(@lengths_chunk) == $size      or die \"decompression error\";\n            scalar(@indices_chunk) == $size      or die \"decompression error\";\n\n            print $out_fh lz77_decompression(\\@uncompressed_chunk, \\@indices_chunk, \\@lengths_chunk);\n        }\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzbwad_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 05 September 2023\n# Edit: 07 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + fixed-width integers encoding + Burrows-Wheeler Transform (BWT) + Adaptive Arithmetic Coding.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n#\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\n\nuse constant {\n    PKGNAME => 'LZBWAD',\n    VERSION => '0.01',\n    FORMAT  => 'lzbwad',\n\n    CHUNK_SIZE    => 1 << 16,    # higher value = better compression\n    LOOKAHEAD_LEN => 128,\n};\n\n# Arithmetic Coding settings\nuse constant BITS         => 32;\nuse constant MAX          => oct('0b' . ('1' x BITS));\nuse constant INITIAL_FREQ => 1;\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n < 255\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        --$n;\n        push @$indices,      $la - $p;\n        push @$lengths,      $n;\n        push @$uncompressed, ord($chars[$la + $n]);\n        $la += $n + 1;\n        $prefix .= $token;\n    }\n\n    return;\n}\n\nsub lz77_decompression ($uncompressed, $indices, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#{$uncompressed}) {\n        $chunk .= substr($chunk, $offset - $indices->[$i], $lengths->[$i]) . $uncompressed->[$i];\n        $offset += $lengths->[$i] + 1;\n    }\n\n    return $chunk;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub encode_integers ($integers) {\n\n    my @counts;\n    my $count           = 0;\n    my $bits_width      = 1;\n    my $bits_max_symbol = 1 << $bits_width;\n    my $processed_len   = 0;\n\n    foreach my $k (@$integers) {\n        while ($k >= $bits_max_symbol) {\n\n            if ($count > 0) {\n                push @counts, [$bits_width, $count];\n                $processed_len += $count;\n            }\n\n            $count = 0;\n            $bits_max_symbol *= 2;\n            $bits_width      += 1;\n        }\n        ++$count;\n    }\n\n    push @counts, grep { $_->[1] > 0 } [$bits_width, scalar(@$integers) - $processed_len];\n\n    my $compressed = delta_encode([(map { $_->[0] } @counts), (map { $_->[1] } @counts)]);\n\n    my $bits = '';\n    foreach my $pair (@counts) {\n        my ($blen, $len) = @$pair;\n        foreach my $symbol (splice(@$integers, 0, $len)) {\n            $bits .= sprintf(\"%0*b\", $blen, $symbol);\n        }\n    }\n\n    $compressed .= pack('B*', $bits);\n    return $compressed;\n}\n\nsub decode_integers ($fh) {\n\n    my $ints = delta_decode($fh);\n    my $half = scalar(@$ints) >> 1;\n\n    my @counts;\n    foreach my $i (0 .. ($half - 1)) {\n        push @counts, [$ints->[$i], $ints->[$half + $i]];\n    }\n\n    my $bits_len = 0;\n\n    foreach my $pair (@counts) {\n        my ($blen, $len) = @$pair;\n        $bits_len += $blen * $len;\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @integers;\n    foreach my $pair (@counts) {\n        my ($blen, $len) = @$pair;\n        foreach my $chunk (unpack(sprintf('(a%d)*', $blen), substr($bits, 0, $blen * $len, ''))) {\n            push @integers, oct('0b' . $chunk);\n        }\n    }\n\n    return \\@integers;\n}\n\nsub create_cfreq ($freq_value, $max_symbol) {\n\n    my $T = 0;\n    my (@cf, @freq);\n\n    foreach my $i (0 .. $max_symbol) {\n        $freq[$i] = $freq_value;\n        $cf[$i]   = $T;\n        $T += $freq_value;\n        $cf[$i + 1] = $T;\n    }\n\n    return (\\@freq, \\@cf, $T);\n}\n\nsub increment_freq ($c, $max_symbol, $freq, $cf) {\n\n    ++$freq->[$c];\n    my $T = $cf->[$c];\n\n    foreach my $i ($c .. $max_symbol) {\n        $cf->[$i] = $T;\n        $T += $freq->[$i];\n        $cf->[$i + 1] = $T;\n    }\n\n    return $T;\n}\n\nsub ac_encode ($bytes_arr) {\n\n    my $enc   = '';\n    my @bytes = (@$bytes_arr, (max(@$bytes_arr) // 0) + 1);\n\n    my $max_symbol = max(@bytes) // 0;\n    my ($freq, $cf, $T) = create_cfreq(INITIAL_FREQ, $max_symbol);\n\n    if ($T > MAX) {\n        die \"Too few bits: $T > ${\\MAX}\";\n    }\n\n    my $low      = 0;\n    my $high     = MAX;\n    my $uf_count = 0;\n\n    foreach my $c (@bytes) {\n\n        my $w = $high - $low + 1;\n\n        $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$c]) / $T)) & MAX;\n\n        $T = increment_freq($c, $max_symbol, $freq, $cf);\n\n        if ($high > MAX) {\n            die \"high > MAX: $high > ${\\MAX}\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n\n                my $bit = $high >> (BITS - 1);\n                $enc .= $bit;\n\n                if ($uf_count > 0) {\n                    $enc .= join('', 1 - $bit) x $uf_count;\n                    $uf_count = 0;\n                }\n\n                $low <<= 1;\n                ($high <<= 1) |= 1;\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                ++$uf_count;\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n        }\n    }\n\n    $enc .= '0';\n    $enc .= '1';\n\n    while (length($enc) % 8 != 0) {\n        $enc .= '1';\n    }\n\n    return ($enc, $max_symbol);\n}\n\nsub ac_decode ($fh, $max_symbol) {\n\n    my ($freq, $cf, $T) = create_cfreq(INITIAL_FREQ, $max_symbol);\n\n    my @dec;\n    my $low  = 0;\n    my $high = MAX;\n\n    my $enc = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS);\n\n    while (1) {\n        my $w  = ($high + 1) - $low;\n        my $ss = int((($T * ($enc - $low + 1)) - 1) / $w);\n\n        my $i = 0;\n        foreach my $j (0 .. $max_symbol) {\n            if ($cf->[$j] <= $ss and $ss < $cf->[$j + 1]) {\n                $i = $j;\n                last;\n            }\n        }\n\n        last if ($i == $max_symbol);\n        push @dec, $i;\n\n        $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$i]) / $T)) & MAX;\n\n        $T = increment_freq($i, $max_symbol, $freq, $cf);\n\n        if ($high > MAX) {\n            die \"high > MAX: ($high > ${\\MAX})\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n                ($high <<= 1) |= 1;\n                $low <<= 1;\n                ($enc <<= 1) |= (getc($fh) // 1);\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1);\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n            $enc  &= MAX;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub create_ac_entry ($bytes, $out_fh) {\n\n    my ($enc, $max_symbol) = ac_encode($bytes);\n\n    print $out_fh delta_encode([$max_symbol, length($enc)], 1);\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_ac_entry ($fh) {\n\n    my ($max_symbol, $enc_len) = @{delta_decode($fh, 1)};\n\n    say \"Encoded length: $enc_len\";\n\n    if ($enc_len > 0) {\n        my $bits = read_bits($fh, $enc_len);\n        open my $bits_fh, '<:raw', \\$bits;\n        return ac_decode($bits_fh, $max_symbol);\n    }\n\n    return [];\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        if ($enc == 0) {\n            $populated <<= 1;\n        }\n        else {\n            ($populated <<= 1) |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta);\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh) // die \"error\")));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\nsub bz2_compression ($chunk, $out_fh) {\n\n    my $rle1 = rle4_encode([unpack('C*', $chunk)]);\n    my ($bwt, $idx) = bwt_encode(pack('C*', @$rle1));\n\n    say \"BWT index = $idx\";\n\n    my @bytes        = unpack('C*', $bwt);\n    my @alphabet     = sort { $a <=> $b } uniq(@bytes);\n    my $alphabet_enc = encode_alphabet(\\@alphabet);\n\n    my $mtf = mtf_encode(\\@bytes, [@alphabet]);\n    my $rle = rle_encode($mtf);\n\n    print $out_fh pack('N', $idx);\n    print $out_fh $alphabet_enc;\n    create_ac_entry($rle, $out_fh);\n}\n\nsub bz2_decompression ($fh, $out_fh) {\n\n    my $idx      = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4));\n    my $alphabet = decode_alphabet($fh);\n\n    say \"BWT index = $idx\";\n    say \"Alphabet size: \", scalar(@$alphabet);\n\n    my $rle  = decode_ac_entry($fh);\n    my $mtf  = rle_decode($rle);\n    my $bwt  = mtf_decode($mtf, $alphabet);\n    my $rle4 = bwt_decode(pack('C*', @$bwt), $idx);\n    my $data = rle4_decode([unpack('C*', $rle4)]);\n\n    print $out_fh pack('C*', @$data);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    my $lengths      = '';\n    my $uncompressed = '';\n\n    my @sizes;\n    my @indices_block;\n\n    open my $uc_fh,  '>:raw', \\$uncompressed;\n    open my $len_fh, '>:raw', \\$lengths;\n\n    my $create_bz2_block = sub {\n\n        scalar(@sizes) > 0 or return;\n\n        print $out_fh delta_encode(\\@sizes, 1);\n\n        my $indices = encode_integers(\\@indices_block);\n\n        bz2_compression($uncompressed, $out_fh);\n        bz2_compression($lengths,      $out_fh);\n        bz2_compression($indices,      $out_fh);\n\n        @sizes         = ();\n        @indices_block = ();\n\n        open $uc_fh,  '>:raw', \\$uncompressed;\n        open $len_fh, '>:raw', \\$lengths;\n    };\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my (@uncompressed, @indices, @lengths);\n        lz77_compression($chunk, \\@uncompressed, \\@indices, \\@lengths);\n\n        my $est_ratio = length($chunk) / (4 * scalar(@uncompressed));\n        say \"Est. ratio: \", $est_ratio, \" (\", scalar(@uncompressed), \" uncompressed bytes)\";\n\n        push @sizes, scalar(@uncompressed);\n        print $uc_fh pack('C*', @uncompressed);\n        print $len_fh pack('C*', @lengths);\n        push @indices_block, @indices;\n\n        if (length($uncompressed) >= CHUNK_SIZE) {\n            $create_bz2_block->();\n        }\n    }\n\n    $create_bz2_block->();\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my @sizes = @{delta_decode($fh, 1)};\n\n        my $indices      = '';\n        my $lengths      = '';\n        my $uncompressed = '';\n\n        open my $uc_fh,  '>:raw',  \\$uncompressed;\n        open my $len_fh, '>:raw',  \\$lengths;\n        open my $idx_fh, '+>:raw', \\$indices;\n\n        bz2_decompression($fh, $uc_fh);     # uncompressed\n        bz2_decompression($fh, $len_fh);    # lengths\n        bz2_decompression($fh, $idx_fh);    # indices\n\n        seek($idx_fh, 0, 0);\n\n        my @indices      = @{decode_integers($idx_fh)};\n        my @uncompressed = split(//, $uncompressed);\n        my @lengths      = unpack('C*', $lengths);\n\n        while (@uncompressed) {\n\n            my $size = shift(@sizes) // die \"decompression error\";\n\n            my @uncompressed_chunk = splice(@uncompressed, 0, $size);\n            my @lengths_chunk      = splice(@lengths,      0, $size);\n            my @indices_chunk      = splice(@indices,      0, $size);\n\n            scalar(@uncompressed_chunk) == $size or die \"decompression error\";\n            scalar(@lengths_chunk) == $size      or die \"decompression error\";\n            scalar(@indices_chunk) == $size      or die \"decompression error\";\n\n            print $out_fh lz77_decompression(\\@uncompressed_chunk, \\@indices_chunk, \\@lengths_chunk);\n        }\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzbwd_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 07 September 2023\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + DEFLATE integers encoding + Burrows-Wheeler Transform (BWT) + Huffman coding.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n#\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\n\nuse constant {\n    PKGNAME => 'LZBWD',\n    VERSION => '0.01',\n    FORMAT  => 'lzbwd',\n\n    CHUNK_SIZE    => 1 << 16,                  # higher value = better compression\n    LOOKAHEAD_LEN => 128,\n    MAX_INT       => oct('0b' . ('1' x 32)),\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\n# [distance value, offset bits]\nmy @DISTANCE_SYMBOLS = (map { [$_, 0] } 0 .. 4);\n\nuntil ($DISTANCE_SYMBOLS[-1][0] > MAX_INT) {\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n}\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n < 255\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        --$n;\n        push @$indices,      $la - $p;\n        push @$lengths,      $n;\n        push @$uncompressed, ord($chars[$la + $n]);\n        $la += $n + 1;\n        $prefix .= $token;\n    }\n\n    return;\n}\n\nsub lz77_decompression ($uncompressed, $indices, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#{$uncompressed}) {\n        $chunk .= substr($chunk, $offset - $indices->[$i], $lengths->[$i]) . $uncompressed->[$i];\n        $offset += $lengths->[$i] + 1;\n    }\n\n    return $chunk;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub encode_integers ($integers) {\n\n    my @symbols;\n    my $offset_bits = '';\n\n    foreach my $dist (@$integers) {\n        foreach my $i (0 .. $#DISTANCE_SYMBOLS) {\n            if ($DISTANCE_SYMBOLS[$i][0] > $dist) {\n                push @symbols, $i - 1;\n\n                if ($DISTANCE_SYMBOLS[$i - 1][1] > 0) {\n                    $offset_bits .= sprintf('%0*b', $DISTANCE_SYMBOLS[$i - 1][1], $dist - $DISTANCE_SYMBOLS[$i - 1][0]);\n                }\n                last;\n            }\n        }\n    }\n\n    return (pack('C*', @symbols), pack('B*', $offset_bits));\n}\n\nsub decode_integers ($symbols, $fh) {\n\n    my $bits_len = 0;\n\n    foreach my $i (@$symbols) {\n        $bits_len += $DISTANCE_SYMBOLS[$i][1];\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @distances;\n    foreach my $i (@$symbols) {\n        push @distances, $DISTANCE_SYMBOLS[$i][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$i][1], ''));\n    }\n\n    return \\@distances;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n    say \"Max symbol: $max_symbol\\n\";\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    say \"Encoded length: $enc_len\\n\";\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        if ($enc == 0) {\n            $populated <<= 1;\n        }\n        else {\n            ($populated <<= 1) |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta);\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh))));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\nsub bz2_compression ($chunk, $out_fh) {\n\n    my $rle1 = rle4_encode([unpack('C*', $chunk)]);\n    my ($bwt, $idx) = bwt_encode(pack('C*', @$rle1));\n\n    say \"BWT index = $idx\";\n\n    my @bytes        = unpack('C*', $bwt);\n    my @alphabet     = sort { $a <=> $b } uniq(@bytes);\n    my $alphabet_enc = encode_alphabet(\\@alphabet);\n\n    my $mtf = mtf_encode(\\@bytes, [@alphabet]);\n    my $rle = rle_encode($mtf);\n\n    print $out_fh pack('N', $idx);\n    print $out_fh $alphabet_enc;\n    create_huffman_entry($rle, $out_fh);\n}\n\nsub bz2_decompression ($fh, $out_fh) {\n\n    my $idx      = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4));\n    my $alphabet = decode_alphabet($fh);\n\n    say \"BWT index = $idx\";\n    say \"Alphabet size: \", scalar(@$alphabet);\n\n    my $rle  = decode_huffman_entry($fh);\n    my $mtf  = rle_decode($rle);\n    my $bwt  = mtf_decode($mtf, $alphabet);\n    my $rle4 = bwt_decode(pack('C*', @$bwt), $idx);\n    my $data = rle4_decode([unpack('C*', $rle4)]);\n\n    print $out_fh pack('C*', @$data);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    my $lengths      = '';\n    my $uncompressed = '';\n\n    my @sizes;\n    my @indices_block;\n\n    open my $uc_fh,  '>:raw', \\$uncompressed;\n    open my $len_fh, '>:raw', \\$lengths;\n\n    my $create_bz2_block = sub {\n\n        scalar(@sizes) > 0 or return;\n\n        print $out_fh delta_encode(\\@sizes, 1);\n\n        my ($symbols, $offset_bits) = encode_integers(\\@indices_block);\n\n        bz2_compression($uncompressed, $out_fh);\n        bz2_compression($lengths,      $out_fh);\n        bz2_compression($symbols,      $out_fh);\n        bz2_compression($offset_bits,  $out_fh);\n\n        @sizes         = ();\n        @indices_block = ();\n\n        open $uc_fh,  '>:raw', \\$uncompressed;\n        open $len_fh, '>:raw', \\$lengths;\n    };\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my (@uncompressed, @indices, @lengths);\n        lz77_compression($chunk, \\@uncompressed, \\@indices, \\@lengths);\n\n        my $est_ratio = length($chunk) / (4 * scalar(@uncompressed));\n        say \"Est. ratio: \", $est_ratio, \" (\", scalar(@uncompressed), \" uncompressed bytes)\";\n\n        push @sizes, scalar(@uncompressed);\n        print $uc_fh pack('C*', @uncompressed);\n        print $len_fh pack('C*', @lengths);\n        push @indices_block, @indices;\n\n        if (length($uncompressed) >= CHUNK_SIZE) {\n            $create_bz2_block->();\n        }\n    }\n\n    $create_bz2_block->();\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my @sizes = @{delta_decode($fh, 1)};\n\n        my $lengths      = '';\n        my $uncompressed = '';\n        my $symbols      = '';\n        my $offset_bits  = '';\n\n        open my $uc_fh,      '>:raw',  \\$uncompressed;\n        open my $len_fh,     '>:raw',  \\$lengths;\n        open my $sym_fh,     '+>:raw', \\$symbols;\n        open my $offbits_fh, '+>:raw', \\$offset_bits;\n\n        bz2_decompression($fh, $uc_fh);         # uncompressed\n        bz2_decompression($fh, $len_fh);        # lengths\n        bz2_decompression($fh, $sym_fh);        # symbols\n        bz2_decompression($fh, $offbits_fh);    # offset bits\n\n        seek($offbits_fh, 0, 0);\n\n        my @indices      = @{decode_integers([unpack('C*', $symbols)], $offbits_fh)};\n        my @uncompressed = split(//, $uncompressed);\n        my @lengths      = unpack('C*', $lengths);\n\n        while (@uncompressed) {\n\n            my $size = shift(@sizes) // die \"decompression error\";\n\n            my @uncompressed_chunk = splice(@uncompressed, 0, $size);\n            my @lengths_chunk      = splice(@lengths,      0, $size);\n            my @indices_chunk      = splice(@indices,      0, $size);\n\n            scalar(@uncompressed_chunk) == $size or die \"decompression error\";\n            scalar(@lengths_chunk) == $size      or die \"decompression error\";\n            scalar(@indices_chunk) == $size      or die \"decompression error\";\n\n            print $out_fh lz77_decompression(\\@uncompressed_chunk, \\@indices_chunk, \\@lengths_chunk);\n        }\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzbwh_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 07 September 2023\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + DEFLATE integers encoding + Burrows-Wheeler Transform (BWT) + Huffman coding.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n#\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\n\nuse constant {\n    PKGNAME => 'LZBWH',\n    VERSION => '0.01',\n    FORMAT  => 'lzbwh',\n\n    CHUNK_SIZE    => 1 << 16,                  # higher value = better compression\n    LOOKAHEAD_LEN => 128,\n    MAX_INT       => oct('0b' . ('1' x 32)),\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\n# [distance value, offset bits]\nmy @DISTANCE_SYMBOLS = (map { [$_, 0] } 0 .. 4);\n\nuntil ($DISTANCE_SYMBOLS[-1][0] > MAX_INT) {\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n}\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n < 255\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        --$n;\n        push @$indices,      $la - $p;\n        push @$lengths,      $n;\n        push @$uncompressed, ord($chars[$la + $n]);\n        $la += $n + 1;\n        $prefix .= $token;\n    }\n\n    return;\n}\n\nsub lz77_decompression ($uncompressed, $indices, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#{$uncompressed}) {\n        $chunk .= substr($chunk, $offset - $indices->[$i], $lengths->[$i]) . $uncompressed->[$i];\n        $offset += $lengths->[$i] + 1;\n    }\n\n    return $chunk;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub encode_integers ($integers) {\n\n    my @symbols;\n    my $offset_bits = '';\n\n    foreach my $dist (@$integers) {\n        foreach my $i (0 .. $#DISTANCE_SYMBOLS) {\n            if ($DISTANCE_SYMBOLS[$i][0] > $dist) {\n                push @symbols, $i - 1;\n\n                if ($DISTANCE_SYMBOLS[$i - 1][1] > 0) {\n                    $offset_bits .= sprintf('%0*b', $DISTANCE_SYMBOLS[$i - 1][1], $dist - $DISTANCE_SYMBOLS[$i - 1][0]);\n                }\n                last;\n            }\n        }\n    }\n\n    my $str = '';\n    open(my $out_fh, '>:raw', \\$str);\n    create_huffman_entry(\\@symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n    return $str;\n}\n\nsub decode_integers ($fh) {\n\n    my $symbols  = decode_huffman_entry($fh);\n    my $bits_len = 0;\n\n    foreach my $i (@$symbols) {\n        $bits_len += $DISTANCE_SYMBOLS[$i][1];\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @distances;\n    foreach my $i (@$symbols) {\n        push @distances, $DISTANCE_SYMBOLS[$i][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$i][1], ''));\n    }\n\n    return \\@distances;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n    say \"Max symbol: $max_symbol\\n\";\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    say \"Encoded length: $enc_len\\n\";\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        if ($enc == 0) {\n            $populated <<= 1;\n        }\n        else {\n            ($populated <<= 1) |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta);\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh))));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\nsub bz2_compression ($chunk, $out_fh) {\n\n    my $rle1 = rle4_encode([unpack('C*', $chunk)]);\n    my ($bwt, $idx) = bwt_encode(pack('C*', @$rle1));\n\n    say \"BWT index = $idx\";\n\n    my @bytes        = unpack('C*', $bwt);\n    my @alphabet     = sort { $a <=> $b } uniq(@bytes);\n    my $alphabet_enc = encode_alphabet(\\@alphabet);\n\n    my $mtf = mtf_encode(\\@bytes, [@alphabet]);\n    my $rle = rle_encode($mtf);\n\n    print $out_fh pack('N', $idx);\n    print $out_fh $alphabet_enc;\n    create_huffman_entry($rle, $out_fh);\n}\n\nsub bz2_decompression ($fh, $out_fh) {\n\n    my $idx      = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4));\n    my $alphabet = decode_alphabet($fh);\n\n    say \"BWT index = $idx\";\n    say \"Alphabet size: \", scalar(@$alphabet);\n\n    my $rle  = decode_huffman_entry($fh);\n    my $mtf  = rle_decode($rle);\n    my $bwt  = mtf_decode($mtf, $alphabet);\n    my $rle4 = bwt_decode(pack('C*', @$bwt), $idx);\n    my $data = rle4_decode([unpack('C*', $rle4)]);\n\n    print $out_fh pack('C*', @$data);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    my $lengths      = '';\n    my $uncompressed = '';\n\n    my @sizes;\n    my @indices_block;\n\n    open my $uc_fh,  '>:raw', \\$uncompressed;\n    open my $len_fh, '>:raw', \\$lengths;\n\n    my $create_bz2_block = sub {\n\n        scalar(@sizes) > 0 or return;\n\n        print $out_fh delta_encode(\\@sizes, 1);\n\n        my $indices = encode_integers(\\@indices_block);\n\n        bz2_compression($uncompressed, $out_fh);\n        bz2_compression($lengths,      $out_fh);\n        bz2_compression($indices,      $out_fh);\n\n        @sizes         = ();\n        @indices_block = ();\n\n        open $uc_fh,  '>:raw', \\$uncompressed;\n        open $len_fh, '>:raw', \\$lengths;\n    };\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my (@uncompressed, @indices, @lengths);\n        lz77_compression($chunk, \\@uncompressed, \\@indices, \\@lengths);\n\n        my $est_ratio = length($chunk) / (4 * scalar(@uncompressed));\n        say \"Est. ratio: \", $est_ratio, \" (\", scalar(@uncompressed), \" uncompressed bytes)\";\n\n        push @sizes, scalar(@uncompressed);\n        print $uc_fh pack('C*', @uncompressed);\n        print $len_fh pack('C*', @lengths);\n        push @indices_block, @indices;\n\n        if (length($uncompressed) >= CHUNK_SIZE) {\n            $create_bz2_block->();\n        }\n    }\n\n    $create_bz2_block->();\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my @sizes = @{delta_decode($fh, 1)};\n\n        my $indices      = '';\n        my $lengths      = '';\n        my $uncompressed = '';\n\n        open my $uc_fh,  '>:raw',  \\$uncompressed;\n        open my $len_fh, '>:raw',  \\$lengths;\n        open my $idx_fh, '+>:raw', \\$indices;\n\n        bz2_decompression($fh, $uc_fh);     # uncompressed\n        bz2_decompression($fh, $len_fh);    # lengths\n        bz2_decompression($fh, $idx_fh);    # indices\n\n        seek($idx_fh, 0, 0);\n\n        my @indices      = @{decode_integers($idx_fh)};\n        my @uncompressed = split(//, $uncompressed);\n        my @lengths      = unpack('C*', $lengths);\n\n        while (@uncompressed) {\n\n            my $size = shift(@sizes) // die \"decompression error\";\n\n            my @uncompressed_chunk = splice(@uncompressed, 0, $size);\n            my @lengths_chunk      = splice(@lengths,      0, $size);\n            my @indices_chunk      = splice(@indices,      0, $size);\n\n            scalar(@uncompressed_chunk) == $size or die \"decompression error\";\n            scalar(@lengths_chunk) == $size      or die \"decompression error\";\n            scalar(@indices_chunk) == $size      or die \"decompression error\";\n\n            print $out_fh lz77_decompression(\\@uncompressed_chunk, \\@indices_chunk, \\@lengths_chunk);\n        }\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzh_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# Edit: 19 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + Huffman coding.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max);\n\nuse constant {\n              PKGNAME    => 'LZH',\n              VERSION    => '0.02',\n              FORMAT     => 'lzh',\n              CHUNK_SIZE => 1 << 16,\n             };\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(2);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = 0;\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n < 255\n               and $la + $n <= $end\n               and ($tmp = index($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        --$n;\n        push @$indices,      $p;\n        push @$lengths,      $n;\n        push @$uncompressed, $chars[$la + $n];\n        $la += $n + 1;\n        $prefix .= $token;\n    }\n\n    return;\n}\n\nsub lz77_decompression ($uncompressed, $indices, $lengths) {\n\n    my $ret   = '';\n    my $chunk = '';\n\n    foreach my $i (0 .. $#{$uncompressed}) {\n        $chunk .= substr($chunk, $indices->[$i], $lengths->[$i]) . chr($uncompressed->[$i]);\n        if (length($chunk) >= CHUNK_SIZE) {\n            $ret .= $chunk;\n            $chunk = '';\n        }\n    }\n\n    if ($chunk ne '') {\n        $ret .= $chunk;\n    }\n\n    $ret;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n    say \"Max symbol: $max_symbol\";\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    my (@uncompressed, @indices, @lengths);\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        lz77_compression($chunk, \\@uncompressed, \\@indices, \\@lengths);\n    }\n\n    @indices      = unpack('C*', pack('S*', @indices));\n    @uncompressed = unpack('C*', join('', @uncompressed));\n\n    create_huffman_entry(\\@uncompressed, $out_fh);\n    create_huffman_entry(\\@indices,      $out_fh);\n    create_huffman_entry(\\@lengths,      $out_fh);\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    my $uncompressed = decode_huffman_entry($fh);\n    my @indices      = unpack('S*', pack('C*', @{decode_huffman_entry($fh)}));\n    my $lengths      = decode_huffman_entry($fh);\n\n    print $out_fh lz77_decompression($uncompressed, \\@indices, $lengths);\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzhc_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Created on: 21 May 2014\n# Latest edit on: 26 April 2015\n# Website: https://github.com/trizen\n\n# A new type of LZ compression + Huffman coding, featuring a very short decompression time.\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\n\nuse constant {\n              PKGNAME => 'lzhc',\n              VERSION => '0.02',\n              FORMAT  => 'lzhc',\n             };\n\nuse constant {\n              MIN       => 4,\n              BUFFER    => 256,\n              SIGNATURE => uc(FORMAT) . chr(2),\n             };\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub walk {\n    my ($n, $s, $h) = @_;\n    if (exists($n->{a})) {\n        $h->{$n->{a}} = $s;\n        return 1;\n    }\n    walk($n->{'0'}, $s . '0', $h);\n    walk($n->{'1'}, $s . '1', $h);\n}\n\nsub mktree {\n    my ($text) = @_;\n\n    my %letters;\n    ++$letters{$_} for (split(//, $text));\n\n    my @nodes;\n    if ((@nodes = map { {a => $_, freq => $letters{$_}} } keys %letters) == 1) {\n        return {$nodes[0]{a} => '0'};\n    }\n\n    my %n;\n    while ((@nodes = sort { $a->{freq} <=> $b->{freq} } @nodes) > 1) {\n        %n = ('0' => {%{shift(@nodes)}}, '1' => {%{shift(@nodes)}});\n        $n{freq} = $n{'0'}{freq} + $n{'1'}{freq};\n        push @nodes, {%n};\n\n    }\n\n    walk(\\%n, '', $n{tree} = {});\n    return $n{tree};\n}\n\nsub huffman_encode {\n    my ($str, $dict) = @_;\n    join('', map { $dict->{$_} // die(\"bad char $_\") } split(//, $str));\n}\n\nsub huffman_decode {\n    my ($hash, $bytes) = @_;\n    local $\" = '|';\n    unpack('B*', $bytes) =~ s/(@{[sort {length($a) <=> length($b)} keys %{$hash}]})/$hash->{$1}/gr;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub compress {\n    my ($input, $output) = @_;\n\n    # Open the input file\n    open my $fh, '<:raw', $input;\n\n    # Open the output file and write the archive signature\n    open my $out_fh, '>:raw', $output;\n    print {$out_fh} SIGNATURE;\n\n    while ((my $len = read($fh, (my $block), BUFFER)) > 0) {\n\n        my %dict;\n        my $max = int($len / 2);\n\n        foreach my $i (reverse(MIN .. $max)) {\n            foreach my $j (0 .. $len - $i * 2) {\n                if ((my $pos = index($block, substr($block, $j, $i), $j + $i)) != -1) {\n                    if (not exists $dict{$pos} or $i > $dict{$pos}[1]) {\n                        $dict{$pos} = [$j, $i];\n                    }\n                }\n            }\n        }\n\n        my @pairs;\n        my $uncompressed = '';\n        for (my $i = 0 ; $i < $len ; $i++) {\n            if (exists $dict{$i}) {\n                my ($key, $vlen) = @{$dict{$i}};\n                push @pairs, [$i, $key, $vlen];\n                $i += $vlen - 1;\n            }\n            else {\n                $uncompressed .= substr($block, $i, 1);\n            }\n        }\n\n        my $huffman_hash = mktree($uncompressed);\n        my $huffman_enc  = huffman_encode($uncompressed, $huffman_hash);\n\n        my %huffman_dict;\n        foreach my $k (keys %{$huffman_hash}) {\n            push @{$huffman_dict{length($huffman_hash->{$k})}}, [$k, $huffman_hash->{$k}];\n        }\n\n        {\n            use bytes;\n\n            my $binary_enc   = pack('B*', $huffman_enc);\n            my $encoding_len = length($binary_enc);\n\n            printf(\"%3d -> %3d (%.2f%%)\\n\", $len, $encoding_len, ($len - $encoding_len) / $len * 100);\n            print {$out_fh}\n\n              # Length of the uncompressed text\n              chr(length($uncompressed) - 1),\n\n              # LZT pairs num\n              chr($#pairs + 1),\n\n              # LZT pairs encoded into bytes\n              (\n                map {\n                    map { chr }\n                      @{$_}\n                  } @pairs\n              ),\n\n              # Huffman dictionary size\n              chr(scalar(keys(%huffman_dict)) > 0 ? scalar(keys(%huffman_dict)) - 1 : 0),\n\n              # Huffman dictionary into bytes\n              (\n                join(\n                    '',\n                    map {\n                            chr($_)\n                          . chr($#{$huffman_dict{$_}} + 1)\n                          . join('', map { $_->[0] } @{$huffman_dict{$_}})\n                          . pack('B*', join('', map { $_->[1] } @{$huffman_dict{$_}}))\n                      } sort { $a <=> $b } keys %huffman_dict\n                    )\n              ),\n\n              # Huffman encoded bytes length\n              chr($encoding_len - 1),\n\n              # Huffman encoded bytes\n              $binary_enc\n        }\n\n        #   exit;\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nsub decompress {\n    my ($input, $output) = @_;\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input;\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output;\n\n    while (read($fh, (my $len_byte), 1) > 0) {\n        read($fh, (my $lzt_pairs), 1);\n\n        # Create the LZT dictionary\n        my %dict;\n        for my $i (1 .. ord($lzt_pairs)) {\n            read($fh, (my $at_byte),   1);\n            read($fh, (my $from_byte), 1);\n            read($fh, (my $size_byte), 1);\n            $dict{ord($at_byte)} = [ord($from_byte), ord($size_byte)];\n        }\n\n        read($fh, (my $huffman_pairs), 1);\n\n        # Create the Huffman dictionary\n        my %huffman_dict;\n        for my $i (1 .. ord($huffman_pairs) + 1) {\n            read($fh, (my $pattern_len), 1);\n            read($fh, (my $pattern_num), 1);\n\n            my $bits_num = ord($pattern_len) * ord($pattern_num);\n\n            if ($bits_num % 8 != 0) {\n                $bits_num += 8 - ($bits_num % 8);\n            }\n\n            read($fh, (my $chars),    ord($pattern_num));\n            read($fh, (my $patterns), $bits_num / 8);\n\n            my $bits = unpack('B*', $patterns);\n            foreach my $char (split(//, $chars)) {\n                $huffman_dict{substr($bits, 0, ord($pattern_len), '')} = $char;\n            }\n        }\n\n        read($fh, (my $bytes_len), 1);\n        read($fh, (my $bytes),     ord($bytes_len) + 1);\n\n        # Huffman decoding\n        my $len   = ord($len_byte) + 1;\n        my $block = substr(huffman_decode(\\%huffman_dict, $bytes), 0, $len);\n\n        my $acc          = 0;\n        my $decompressed = '';\n\n        # LZT decoding\n        for (my $i = 0 ; $i <= $len ; $i++) {\n            if (exists($dict{$i + $acc})) {\n                my $pos = $dict{$i + $acc};\n                $decompressed .= substr($decompressed, $pos->[0], $pos->[1]);\n                $acc += $pos->[1];\n                $i--;\n            }\n            else {\n                $decompressed .= substr($block, $i, 1);\n            }\n        }\n\n        print {$out_fh} $decompressed;\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzhd_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# Edit: 13 June 2023\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + Huffman coding.\n\n# Encoding the distances/indices using a DEFLATE-like approach.\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max);\n\nuse constant {\n    PKGNAME => 'LZHD',\n    VERSION => '0.02',\n    FORMAT  => 'lzhd',\n\n    CHUNK_SIZE => 1 << 16,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(2);\n\n# [distance value, offset bits]\nmy @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4);\n\nuntil ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) {\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n}\n\nmy @DISTANCE_INDICES;\n\nforeach my $i (0 .. $#DISTANCE_SYMBOLS) {\n    my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        last if ($k > CHUNK_SIZE);\n        $DISTANCE_INDICES[$k] = $i;\n    }\n}\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n < 255\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        --$n;\n        push @$indices,      $la - $p;\n        push @$lengths,      $n;\n        push @$uncompressed, ord($chars[$la + $n]);\n        $la += $n + 1;\n        $prefix .= $token;\n    }\n\n    return;\n}\n\nsub lz77_decompression ($uncompressed, $indices, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#{$uncompressed}) {\n        $chunk .= substr($chunk, $offset - $indices->[$i], $lengths->[$i]) . $uncompressed->[$i];\n        $offset += $lengths->[$i] + 1;\n    }\n\n    return $chunk;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1}/gr;    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    foreach my $k (keys %$rev_dict) {\n        $rev_dict->{$k} = chr($rev_dict->{$k});\n    }\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return '';\n}\n\nsub encode_distances ($distances, $out_fh) {\n\n    my @symbols;\n    my $offset_bits = '';\n\n    foreach my $dist (@$distances) {\n\n        my $i = $DISTANCE_INDICES[$dist];\n        my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n\n        push @symbols, $i;\n\n        if ($bits > 0) {\n            $offset_bits .= sprintf('%0*b', $bits, $dist - $min);\n        }\n    }\n\n    create_huffman_entry(\\@symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n}\n\nsub decode_distances ($fh) {\n\n    my @symbols  = unpack('C*', decode_huffman_entry($fh));\n    my $bits_len = 0;\n\n    foreach my $i (@symbols) {\n        $bits_len += $DISTANCE_SYMBOLS[$i][1];\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @distances;\n    foreach my $i (@symbols) {\n        push @distances, $DISTANCE_SYMBOLS[$i][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$i][1], ''));\n    }\n\n    return \\@distances;\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my (@uncompressed, @indices, @lengths);\n        lz77_compression($chunk, \\@uncompressed, \\@indices, \\@lengths);\n\n        my $est_ratio = length($chunk) / (4 * scalar(@uncompressed));\n\n        say(scalar(@uncompressed), ' -> ', $est_ratio);\n\n        create_huffman_entry(\\@uncompressed, $out_fh);\n        create_huffman_entry(\\@lengths,      $out_fh);\n        encode_distances(\\@indices, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my @uncompressed = split(//, decode_huffman_entry($fh));\n        my @lengths      = unpack('C*', decode_huffman_entry($fh));\n        my $indices      = decode_distances($fh);\n\n        print $out_fh lz77_decompression(\\@uncompressed, $indices, \\@lengths);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzih_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 15 December 2022\n# Edit: 13 June 2023\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression + fixed-width integers encoding + Huffman coding.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max);\n\nuse constant {\n    PKGNAME => 'LZIH',\n    VERSION => '0.04',\n    FORMAT  => 'lzih',\n\n    CHUNK_SIZE => 1 << 16,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(4);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n < 255\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        --$n;\n        push @$indices,      $la - $p;\n        push @$lengths,      $n;\n        push @$uncompressed, ord($chars[$la + $n]);\n        $la += $n + 1;\n        $prefix .= $token;\n    }\n\n    return;\n}\n\nsub lz77_decompression ($uncompressed, $indices, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#{$uncompressed}) {\n        $chunk .= substr($chunk, $offset - $indices->[$i], $lengths->[$i]) . $uncompressed->[$i];\n        $offset += $lengths->[$i] + 1;\n    }\n\n    return $chunk;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub encode_integers ($integers) {\n\n    my @counts;\n    my $count           = 0;\n    my $bits_width      = 1;\n    my $bits_max_symbol = 1 << $bits_width;\n    my $processed_len   = 0;\n\n    foreach my $k (@$integers) {\n        while ($k >= $bits_max_symbol) {\n\n            if ($count > 0) {\n                push @counts, [$bits_width, $count];\n                $processed_len += $count;\n            }\n\n            $count = 0;\n            $bits_max_symbol *= 2;\n            $bits_width      += 1;\n        }\n        ++$count;\n    }\n\n    push @counts, grep { $_->[1] > 0 } [$bits_width, scalar(@$integers) - $processed_len];\n\n    my $compressed = delta_encode([(map { $_->[0] } @counts), (map { $_->[1] } @counts)]);\n\n    my $bits = '';\n    foreach my $pair (@counts) {\n        my ($blen, $len) = @$pair;\n        foreach my $symbol (splice(@$integers, 0, $len)) {\n            $bits .= sprintf(\"%0*b\", $blen, $symbol);\n        }\n    }\n\n    $compressed .= pack('B*', $bits);\n    return $compressed;\n}\n\nsub decode_integers ($fh) {\n\n    my $ints = delta_decode($fh);\n    my $half = scalar(@$ints) >> 1;\n\n    my @counts;\n    foreach my $i (0 .. ($half - 1)) {\n        push @counts, [$ints->[$i], $ints->[$half + $i]];\n    }\n\n    my $bits_len = 0;\n\n    foreach my $pair (@counts) {\n        my ($blen, $len) = @$pair;\n        $bits_len += $blen * $len;\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @integers;\n    foreach my $pair (@counts) {\n        my ($blen, $len) = @$pair;\n        foreach my $chunk (unpack(sprintf('(a%d)*', $blen), substr($bits, 0, $blen * $len, ''))) {\n            push @integers, oct('0b' . $chunk);\n        }\n    }\n\n    return \\@integers;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1}/gr;    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    foreach my $k (keys %$rev_dict) {\n        $rev_dict->{$k} = chr($rev_dict->{$k});\n    }\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return '';\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my (@uncompressed, @indices, @lengths);\n        lz77_compression($chunk, \\@uncompressed, \\@indices, \\@lengths);\n\n        my $est_ratio = length($chunk) / (4 * scalar(@uncompressed));\n\n        say(scalar(@uncompressed), ' -> ', $est_ratio);\n\n        create_huffman_entry(\\@uncompressed, $out_fh);\n        create_huffman_entry(\\@lengths,      $out_fh);\n        print $out_fh encode_integers(\\@indices);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n\n        my @uncompressed = split(//, decode_huffman_entry($fh));\n        my @lengths      = unpack('C*', decode_huffman_entry($fh));\n        my $indices      = decode_integers($fh);\n\n        print $out_fh lz77_decompression(\\@uncompressed, $indices, \\@lengths);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzsa_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 June 2023\n# Edit: 12 August 2023\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression (LZSS variant) + Arithmetic Coding (in fixed bits).\n\n# Encoding the literals and the pointers using a DEFLATE-like approach.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n#\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max sum);\nuse POSIX          qw(ceil log2);\n\nuse constant {\n    PKGNAME => 'LZSA',\n    VERSION => '0.02',\n    FORMAT  => 'lzsa',\n\n    CHUNK_SIZE => 1 << 16,    # higher value = better compression\n};\n\n# Arithmetic Coding settings\nuse constant BITS => 32;\nuse constant MAX  => oct('0b' . ('1' x BITS));\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(2);\n\n# [distance value, offset bits]\nmy @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4);\n\nuntil ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) {\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n}\n\n# [length, offset bits]\nmy @LENGTH_SYMBOLS = ((map { [$_, 0] } (3 .. 10)));\n\n{\n    my $delta = 1;\n    until ($LENGTH_SYMBOLS[-1][0] > 163) {\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1];\n        $delta *= 2;\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n    }\n    push @LENGTH_SYMBOLS, [258, 0];\n}\n\nmy @DISTANCE_INDICES;\n\nforeach my $i (0 .. $#DISTANCE_SYMBOLS) {\n    my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        last if ($k > CHUNK_SIZE);\n        $DISTANCE_INDICES[$k] = $i;\n    }\n}\n\nmy @LENGTH_INDICES;\n\nforeach my $i (0 .. $#LENGTH_SYMBOLS) {\n    my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        $LENGTH_INDICES[$k] = $i;\n    }\n}\n\nsub usage ($code) {\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive ($fh) {\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    my $min_len = $LENGTH_SYMBOLS[0][0];\n    my $max_len = $LENGTH_SYMBOLS[-1][0];\n\n    my %literal_freq;\n    my %distance_freq;\n\n    my $literal_count  = 0;\n    my $distance_count = 0;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n <= $max_len\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        my $enc_bits_len     = 0;\n        my $literal_bits_len = 0;\n\n        if ($n > $min_len) {\n\n            my $dist = $DISTANCE_SYMBOLS[$DISTANCE_INDICES[$la - $p]];\n            $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0))));\n\n            my $len_idx = $LENGTH_INDICES[$n - 1];\n            my $len     = $LENGTH_SYMBOLS[$len_idx];\n\n            $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0))));\n\n            my %freq;\n            foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) {\n                ++$freq{$c};\n                $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0))));\n            }\n        }\n\n        if ($n > $min_len and $enc_bits_len < $literal_bits_len) {\n\n            push @$lengths,      $n - 1;\n            push @$indices,      $la - $p;\n            push @$uncompressed, undef;\n\n            my $dist_idx = $DISTANCE_INDICES[$la - $p];\n            my $dist     = $DISTANCE_SYMBOLS[$dist_idx];\n\n            ++$distance_count;\n            ++$distance_freq{$dist->[0]};\n\n            ++$literal_count;\n            ++$literal_freq{$LENGTH_INDICES[$n - 1] + 256};\n\n            $la += $n - 1;\n            $prefix .= substr($token, 0, -1);\n        }\n        else {\n            my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]);\n\n            push @$uncompressed, @bytes;\n            push @$lengths, (0) x scalar(@bytes);\n            push @$indices, (0) x scalar(@bytes);\n\n            ++$literal_freq{$_} for @bytes;\n\n            $literal_count += $n;\n            $la            += $n;\n            $prefix .= $token;\n        }\n    }\n\n    return;\n}\n\nsub lz77_decompression ($literals, $distances, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#$literals) {\n        if ($lengths->[$i] != 0) {\n            $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]);\n            $offset += $lengths->[$i];\n        }\n        else {\n            $chunk .= chr($literals->[$i]);\n            $offset += 1;\n        }\n    }\n\n    return $chunk;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub create_cfreq ($freq) {\n\n    my @cf;\n    my $T = 0;\n\n    foreach my $i (sort { $a <=> $b } keys %$freq) {\n        $freq->{$i} // next;\n        $cf[$i] = $T;\n        $T += $freq->{$i};\n        $cf[$i + 1] = $T;\n    }\n\n    return (\\@cf, $T);\n}\n\nsub ac_encode ($bytes_arr) {\n\n    my $enc        = '';\n    my $EOF_SYMBOL = (max(@$bytes_arr) // 0) + 1;\n    my @bytes      = (@$bytes_arr, $EOF_SYMBOL);\n\n    my %freq;\n    ++$freq{$_} for @bytes;\n\n    my ($cf, $T) = create_cfreq(\\%freq);\n\n    if ($T > MAX) {\n        die \"Too few bits: $T > ${\\MAX}\";\n    }\n\n    my $low      = 0;\n    my $high     = MAX;\n    my $uf_count = 0;\n\n    foreach my $c (@bytes) {\n\n        my $w = $high - $low + 1;\n\n        $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$c]) / $T)) & MAX;\n\n        if ($high > MAX) {\n            die \"high > MAX: $high > ${\\MAX}\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n\n                my $bit = $high >> (BITS - 1);\n                $enc .= $bit;\n\n                if ($uf_count > 0) {\n                    $enc .= join('', 1 - $bit) x $uf_count;\n                    $uf_count = 0;\n                }\n\n                $low <<= 1;\n                ($high <<= 1) |= 1;\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                ++$uf_count;\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n        }\n    }\n\n    $enc .= '0';\n    $enc .= '1';\n\n    while (length($enc) % 8 != 0) {\n        $enc .= '1';\n    }\n\n    return ($enc, \\%freq);\n}\n\nsub ac_decode ($fh, $freq) {\n\n    my ($cf, $T) = create_cfreq($freq);\n\n    my @dec;\n    my $low  = 0;\n    my $high = MAX;\n    my $enc  = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS);\n\n    my @table;\n    foreach my $i (sort { $a <=> $b } keys %$freq) {\n        foreach my $j ($cf->[$i] .. $cf->[$i + 1] - 1) {\n            $table[$j] = $i;\n        }\n    }\n\n    my $EOF_SYMBOL = max(keys %$freq) // 0;\n\n    while (1) {\n\n        my $w  = $high - $low + 1;\n        my $ss = int((($T * ($enc - $low + 1)) - 1) / $w);\n\n        my $i = $table[$ss] // last;\n        last if ($i == $EOF_SYMBOL);\n\n        push @dec, $i;\n\n        $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$i]) / $T)) & MAX;\n\n        if ($high > MAX) {\n            die \"error\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n                ($high <<= 1) |= 1;\n                $low <<= 1;\n                ($enc <<= 1) |= (getc($fh) // 1);\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1);\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n            $enc  &= MAX;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub create_ac_entry ($bytes, $out_fh) {\n\n    my ($enc, $freq) = ac_encode($bytes);\n    my $max_symbol = max(keys %$freq) // 0;\n\n    my @freqs;\n    foreach my $k (0 .. $max_symbol) {\n        push @freqs, $freq->{$k} // 0;\n    }\n\n    push @freqs, length($enc) >> 3;\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_ac_entry ($fh) {\n\n    my @freqs    = @{delta_decode($fh)};\n    my $bits_len = pop(@freqs);\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    say \"Encoded length: $bits_len\";\n    my $bits = read_bits($fh, $bits_len << 3);\n\n    if ($bits_len > 0) {\n        open my $bits_fh, '<:raw', \\$bits;\n        return ac_decode($bits_fh, \\%freq);\n    }\n\n    return [];\n}\n\nsub deflate_encode ($literals, $distances, $lengths, $out_fh) {\n\n    my @len_symbols;\n    my @dist_symbols;\n    my $offset_bits = '';\n\n    foreach my $j (0 .. $#{$literals}) {\n\n        if ($lengths->[$j] == 0) {\n            push @len_symbols, $literals->[$j];\n            next;\n        }\n\n        my $len  = $lengths->[$j];\n        my $dist = $distances->[$j];\n\n        {\n            my $len_idx = $LENGTH_INDICES[$len];\n            my ($min, $bits) = @{$LENGTH_SYMBOLS[$len_idx]};\n\n            push @len_symbols, $len_idx + 256;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $len - $min);\n            }\n        }\n\n        {\n            my $dist_idx = $DISTANCE_INDICES[$dist];\n            my ($min, $bits) = @{$DISTANCE_SYMBOLS[$dist_idx]};\n\n            push @dist_symbols, $dist_idx;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $dist - $min);\n            }\n        }\n    }\n\n    create_ac_entry(\\@len_symbols,  $out_fh);\n    create_ac_entry(\\@dist_symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n}\n\nsub deflate_decode ($fh) {\n\n    my $len_symbols  = decode_ac_entry($fh);\n    my $dist_symbols = decode_ac_entry($fh);\n\n    my $bits_len = 0;\n\n    foreach my $i (@$dist_symbols) {\n        $bits_len += $DISTANCE_SYMBOLS[$i][1];\n    }\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            $bits_len += $LENGTH_SYMBOLS[$i - 256][1];\n        }\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @literals;\n    my @lengths;\n    my @distances;\n\n    my $j = 0;\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            my $dist = $dist_symbols->[$j++];\n            push @literals,  undef;\n            push @lengths,   $LENGTH_SYMBOLS[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS[$i - 256][1], ''));\n            push @distances, $DISTANCE_SYMBOLS[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$dist][1], ''));\n        }\n        else {\n            push @literals,  $i;\n            push @lengths,   0;\n            push @distances, 0;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my (@uncompressed, @indices, @lengths);\n        lz77_compression($chunk, \\@uncompressed, \\@indices, \\@lengths);\n\n        my $est_ratio = length($chunk) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices));\n        say scalar(@uncompressed), ' -> ', $est_ratio;\n\n        deflate_encode(\\@uncompressed, \\@indices, \\@lengths, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        my ($uncompressed, $indices, $lengths) = deflate_decode($fh);\n        print $out_fh lz77_decompression($uncompressed, $indices, $lengths);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzsad_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 June 2023\n# Edit: 07 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression (LZSS variant) + Adaptive Arithmetic Coding (in fixed bits).\n\n# Encoding the literals and the pointers using a DEFLATE-like approach.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n#\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max sum);\nuse POSIX          qw(ceil log2);\n\nuse constant {\n    PKGNAME => 'LZSAD',\n    VERSION => '0.01',\n    FORMAT  => 'lzsad',\n\n    CHUNK_SIZE => 1 << 16,    # higher value = better compression\n};\n\n# Arithmetic Coding settings\nuse constant BITS         => 32;\nuse constant MAX          => oct('0b' . ('1' x BITS));\nuse constant INITIAL_FREQ => 1;\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\n# [distance value, offset bits]\nmy @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4);\n\nuntil ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) {\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n}\n\n# [length, offset bits]\nmy @LENGTH_SYMBOLS = ((map { [$_, 0] } (3 .. 10)));\n\n{\n    my $delta = 1;\n    until ($LENGTH_SYMBOLS[-1][0] > 163) {\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1];\n        $delta *= 2;\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n    }\n    push @LENGTH_SYMBOLS, [258, 0];\n}\n\nmy @DISTANCE_INDICES;\n\nforeach my $i (0 .. $#DISTANCE_SYMBOLS) {\n    my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        last if ($k > CHUNK_SIZE);\n        $DISTANCE_INDICES[$k] = $i;\n    }\n}\n\nmy @LENGTH_INDICES;\n\nforeach my $i (0 .. $#LENGTH_SYMBOLS) {\n    my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        $LENGTH_INDICES[$k] = $i;\n    }\n}\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    my $min_len = $LENGTH_SYMBOLS[0][0];\n    my $max_len = $LENGTH_SYMBOLS[-1][0];\n\n    my %literal_freq;\n    my %distance_freq;\n\n    my $literal_count  = 0;\n    my $distance_count = 0;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n <= $max_len\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        my $enc_bits_len     = 0;\n        my $literal_bits_len = 0;\n\n        if ($n > $min_len) {\n\n            my $dist = $DISTANCE_SYMBOLS[$DISTANCE_INDICES[$la - $p]];\n            $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0))));\n\n            my $len_idx = $LENGTH_INDICES[$n - 1];\n            my $len     = $LENGTH_SYMBOLS[$len_idx];\n\n            $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0))));\n\n            my %freq;\n            foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) {\n                ++$freq{$c};\n                $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0))));\n            }\n        }\n\n        if ($n > $min_len and $enc_bits_len < $literal_bits_len) {\n\n            push @$lengths,      $n - 1;\n            push @$indices,      $la - $p;\n            push @$uncompressed, undef;\n\n            my $dist_idx = $DISTANCE_INDICES[$la - $p];\n            my $dist     = $DISTANCE_SYMBOLS[$dist_idx];\n\n            ++$distance_count;\n            ++$distance_freq{$dist->[0]};\n\n            ++$literal_count;\n            ++$literal_freq{$LENGTH_INDICES[$n - 1] + 256};\n\n            $la += $n - 1;\n            $prefix .= substr($token, 0, -1);\n        }\n        else {\n            my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]);\n\n            push @$uncompressed, @bytes;\n            push @$lengths, (0) x scalar(@bytes);\n            push @$indices, (0) x scalar(@bytes);\n\n            ++$literal_freq{$_} for @bytes;\n\n            $literal_count += $n;\n            $la            += $n;\n            $prefix .= $token;\n        }\n    }\n\n    return;\n}\n\nsub lz77_decompression ($literals, $distances, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#$literals) {\n        if ($lengths->[$i] != 0) {\n            $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]);\n            $offset += $lengths->[$i];\n        }\n        else {\n            $chunk .= chr($literals->[$i]);\n            $offset += 1;\n        }\n    }\n\n    return $chunk;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub create_cfreq ($freq_value, $max_symbol) {\n\n    my $T = 0;\n    my (@cf, @freq);\n\n    foreach my $i (0 .. $max_symbol) {\n        $freq[$i] = $freq_value;\n        $cf[$i]   = $T;\n        $T += $freq_value;\n        $cf[$i + 1] = $T;\n    }\n\n    return (\\@freq, \\@cf, $T);\n}\n\nsub increment_freq ($c, $max_symbol, $freq, $cf) {\n\n    ++$freq->[$c];\n    my $T = $cf->[$c];\n\n    foreach my $i ($c .. $max_symbol) {\n        $cf->[$i] = $T;\n        $T += $freq->[$i];\n        $cf->[$i + 1] = $T;\n    }\n\n    return $T;\n}\n\nsub ac_encode ($bytes_arr) {\n\n    my $enc   = '';\n    my @bytes = (@$bytes_arr, (max(@$bytes_arr) // 0) + 1);\n\n    my $max_symbol = max(@bytes) // 0;\n    my ($freq, $cf, $T) = create_cfreq(INITIAL_FREQ, $max_symbol);\n\n    if ($T > MAX) {\n        die \"Too few bits: $T > ${\\MAX}\";\n    }\n\n    my $low      = 0;\n    my $high     = MAX;\n    my $uf_count = 0;\n\n    foreach my $c (@bytes) {\n\n        my $w = $high - $low + 1;\n\n        $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$c]) / $T)) & MAX;\n\n        $T = increment_freq($c, $max_symbol, $freq, $cf);\n\n        if ($high > MAX) {\n            die \"high > MAX: $high > ${\\MAX}\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n\n                my $bit = $high >> (BITS - 1);\n                $enc .= $bit;\n\n                if ($uf_count > 0) {\n                    $enc .= join('', 1 - $bit) x $uf_count;\n                    $uf_count = 0;\n                }\n\n                $low <<= 1;\n                ($high <<= 1) |= 1;\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                ++$uf_count;\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n        }\n    }\n\n    $enc .= '0';\n    $enc .= '1';\n\n    while (length($enc) % 8 != 0) {\n        $enc .= '1';\n    }\n\n    return ($enc, $max_symbol);\n}\n\nsub ac_decode ($fh, $max_symbol) {\n\n    my ($freq, $cf, $T) = create_cfreq(INITIAL_FREQ, $max_symbol);\n\n    my @dec;\n    my $low  = 0;\n    my $high = MAX;\n\n    my $enc = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS);\n\n    while (1) {\n        my $w  = ($high + 1) - $low;\n        my $ss = int((($T * ($enc - $low + 1)) - 1) / $w);\n\n        my $i = 0;\n        foreach my $j (0 .. $max_symbol) {\n            if ($cf->[$j] <= $ss and $ss < $cf->[$j + 1]) {\n                $i = $j;\n                last;\n            }\n        }\n\n        last if ($i == $max_symbol);\n        push @dec, $i;\n\n        $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$i]) / $T)) & MAX;\n\n        $T = increment_freq($i, $max_symbol, $freq, $cf);\n\n        if ($high > MAX) {\n            die \"high > MAX: ($high > ${\\MAX})\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n                ($high <<= 1) |= 1;\n                $low <<= 1;\n                ($enc <<= 1) |= (getc($fh) // 1);\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1);\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n            $enc  &= MAX;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub create_ac_entry ($bytes, $out_fh) {\n\n    my ($enc, $max_symbol) = ac_encode($bytes);\n\n    print $out_fh delta_encode([$max_symbol, length($enc)], 1);\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_ac_entry ($fh) {\n\n    my ($max_symbol, $enc_len) = @{delta_decode($fh, 1)};\n\n    say \"Encoded length: $enc_len\";\n\n    if ($enc_len > 0) {\n        my $bits = read_bits($fh, $enc_len);\n        open my $bits_fh, '<:raw', \\$bits;\n        return ac_decode($bits_fh, $max_symbol);\n    }\n\n    return [];\n}\n\nsub deflate_encode ($literals, $distances, $lengths, $out_fh) {\n\n    my @len_symbols;\n    my @dist_symbols;\n    my $offset_bits = '';\n\n    foreach my $j (0 .. $#{$literals}) {\n\n        if ($lengths->[$j] == 0) {\n            push @len_symbols, $literals->[$j];\n            next;\n        }\n\n        my $len  = $lengths->[$j];\n        my $dist = $distances->[$j];\n\n        {\n            my $len_idx = $LENGTH_INDICES[$len];\n            my ($min, $bits) = @{$LENGTH_SYMBOLS[$len_idx]};\n\n            push @len_symbols, $len_idx + 256;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $len - $min);\n            }\n        }\n\n        {\n            my $dist_idx = $DISTANCE_INDICES[$dist];\n            my ($min, $bits) = @{$DISTANCE_SYMBOLS[$dist_idx]};\n\n            push @dist_symbols, $dist_idx;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $dist - $min);\n            }\n        }\n    }\n\n    create_ac_entry(\\@len_symbols,  $out_fh);\n    create_ac_entry(\\@dist_symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n}\n\nsub deflate_decode ($fh) {\n\n    my $len_symbols  = decode_ac_entry($fh);\n    my $dist_symbols = decode_ac_entry($fh);\n\n    my $bits_len = 0;\n\n    foreach my $i (@$dist_symbols) {\n        $bits_len += $DISTANCE_SYMBOLS[$i][1];\n    }\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            $bits_len += $LENGTH_SYMBOLS[$i - 256][1];\n        }\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @literals;\n    my @lengths;\n    my @distances;\n\n    my $j = 0;\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            my $dist = $dist_symbols->[$j++];\n            push @literals,  undef;\n            push @lengths,   $LENGTH_SYMBOLS[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS[$i - 256][1], ''));\n            push @distances, $DISTANCE_SYMBOLS[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$dist][1], ''));\n        }\n        else {\n            push @literals,  $i;\n            push @lengths,   0;\n            push @distances, 0;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my (@uncompressed, @indices, @lengths);\n        lz77_compression($chunk, \\@uncompressed, \\@indices, \\@lengths);\n\n        my $est_ratio = length($chunk) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices));\n        say scalar(@uncompressed), ' -> ', $est_ratio;\n\n        deflate_encode(\\@uncompressed, \\@indices, \\@lengths, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        my ($uncompressed, $indices, $lengths) = deflate_decode($fh);\n        print $out_fh lz77_decompression($uncompressed, $indices, $lengths);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzsbw_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 June 2023\n# Edit: 18 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZSS + Bzip2.\n\n# Encoding the literals and the pointers using a DEFLATE-like approach.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\nuse POSIX          qw(ceil log2);\n\nuse constant {\n    PKGNAME => 'LZSBW',\n    VERSION => '0.01',\n    FORMAT  => 'lzsbw',\n\n    CHUNK_SIZE => 1 << 16,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\n# [distance value, offset bits]\nmy @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4);\n\nuntil ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) {\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n}\n\n# [length, offset bits]\nmy @LENGTH_SYMBOLS = ((map { [$_, 0] } (3 .. 10)));\n\n{\n    my $delta = 1;\n    until ($LENGTH_SYMBOLS[-1][0] > 163) {\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1];\n        $delta *= 2;\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n    }\n    push @LENGTH_SYMBOLS, [258, 0];\n}\n\nmy @DISTANCE_INDICES;\n\nforeach my $i (0 .. $#DISTANCE_SYMBOLS) {\n    my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        last if ($k > CHUNK_SIZE);\n        $DISTANCE_INDICES[$k] = $i;\n    }\n}\n\nmy @LENGTH_INDICES;\n\nforeach my $i (0 .. $#LENGTH_SYMBOLS) {\n    my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        $LENGTH_INDICES[$k] = $i;\n    }\n}\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    my $min_len = $LENGTH_SYMBOLS[0][0];\n    my $max_len = $LENGTH_SYMBOLS[-1][0];\n\n    my %literal_freq;\n    my %distance_freq;\n\n    my $literal_count  = 0;\n    my $distance_count = 0;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n <= $max_len\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        my $enc_bits_len     = 0;\n        my $literal_bits_len = 0;\n\n        if ($n > $min_len) {\n\n            my $dist = $DISTANCE_SYMBOLS[$DISTANCE_INDICES[$la - $p]];\n            $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0))));\n\n            my $len_idx = $LENGTH_INDICES[$n - 1];\n            my $len     = $LENGTH_SYMBOLS[$len_idx];\n\n            $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0))));\n\n            my %freq;\n            foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) {\n                ++$freq{$c};\n                $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0))));\n            }\n        }\n\n        if ($n > $min_len and $enc_bits_len < $literal_bits_len) {\n\n            push @$lengths,      $n - 1;\n            push @$indices,      $la - $p;\n            push @$uncompressed, undef;\n\n            my $dist_idx = $DISTANCE_INDICES[$la - $p];\n            my $dist     = $DISTANCE_SYMBOLS[$dist_idx];\n\n            ++$distance_count;\n            ++$distance_freq{$dist->[0]};\n\n            ++$literal_count;\n            ++$literal_freq{$LENGTH_INDICES[$n - 1] + 256};\n\n            $la += $n - 1;\n            $prefix .= substr($token, 0, -1);\n        }\n        else {\n            my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]);\n\n            push @$uncompressed, @bytes;\n            push @$lengths, (0) x scalar(@bytes);\n            push @$indices, (0) x scalar(@bytes);\n\n            ++$literal_freq{$_} for @bytes;\n\n            $literal_count += $n;\n            $la            += $n;\n            $prefix .= $token;\n        }\n    }\n\n    return;\n}\n\nsub lz77_decompression ($literals, $distances, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#$literals) {\n        if ($lengths->[$i] != 0) {\n            $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]);\n            $offset += $lengths->[$i];\n        }\n        else {\n            $chunk .= chr($literals->[$i]);\n            $offset += 1;\n        }\n    }\n\n    return $chunk;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub bwt_sort_symbolic ($s) {    # O(n) space (slowish)\n\n    my @cyclic = @$s;\n    my $len    = scalar(@cyclic);\n\n    my $rle = 1;\n    foreach my $i (1 .. $len - 1) {\n        if ($cyclic[$i] != $cyclic[$i - 1]) {\n            $rle = 0;\n            last;\n        }\n    }\n\n    $rle && return [0 .. $len - 1];\n\n    [\n     sort {\n         my ($i, $j) = ($a, $b);\n\n         while ($cyclic[$i] == $cyclic[$j]) {\n             $i %= $len if (++$i >= $len);\n             $j %= $len if (++$j >= $len);\n         }\n\n         $cyclic[$i] <=> $cyclic[$j];\n       } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode_symbolic ($s) {\n\n    my $bwt = bwt_sort_symbolic($s);\n    my @ret = map { $s->[$_ - 1] } @$bwt;\n\n    my $idx = 0;\n    foreach my $i (@$bwt) {\n        $i || last;\n        ++$idx;\n    }\n\n    return (\\@ret, $idx);\n}\n\nsub bwt_decode_symbolic ($bwt, $idx) {    # fast inversion\n\n    my @tail = @$bwt;\n    my @head = sort { $a <=> $b } @tail;\n\n    my @indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices[$tail[$i]]}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices[$v]});\n    }\n\n    my @dec;\n    my $i = $idx;\n\n    for (1 .. scalar(@head)) {\n        push @dec, $head[$i];\n        $i = $table[$i];\n    }\n\n    return \\@dec;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet_symbolic ($alphabet) {\n    return delta_encode([@$alphabet]);\n}\n\nsub decode_alphabet_symbolic ($fh) {\n    return [@{delta_decode($fh)}];\n}\n\nsub bz2_compression_symbolic ($symbols, $out_fh) {\n\n    my ($bwt, $idx) = bwt_encode_symbolic($symbols);\n\n    say \"BWT index = $idx\";\n\n    my @bytes        = @$bwt;\n    my @alphabet     = sort { $a <=> $b } uniq(@bytes);\n    my $alphabet_enc = encode_alphabet_symbolic(\\@alphabet);\n\n    my $mtf = mtf_encode(\\@bytes, [@alphabet]);\n    my $rle = rle_encode($mtf);\n\n    print $out_fh pack('N', $idx);\n    print $out_fh $alphabet_enc;\n    create_huffman_entry($rle, $out_fh);\n}\n\nsub bz2_decompression_symbolic ($fh) {\n\n    my $idx      = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    my $alphabet = decode_alphabet_symbolic($fh);\n\n    say \"BWT index = $idx\";\n    say \"Alphabet size: \", scalar(@$alphabet);\n\n    my $rle  = decode_huffman_entry($fh);\n    my $mtf  = rle_decode($rle);\n    my $bwt  = mtf_decode($mtf, $alphabet);\n    my $data = bwt_decode_symbolic($bwt, $idx);\n\n    return $data;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\nsub deflate_encode ($literals, $distances, $lengths, $out_fh) {\n\n    my @len_symbols;\n    my @dist_symbols;\n    my $offset_bits = '';\n\n    foreach my $j (0 .. $#{$literals}) {\n\n        if ($lengths->[$j] == 0) {\n            push @len_symbols, $literals->[$j];\n            next;\n        }\n\n        my $len  = $lengths->[$j];\n        my $dist = $distances->[$j];\n\n        {\n            my $len_idx = $LENGTH_INDICES[$len];\n            my ($min, $bits) = @{$LENGTH_SYMBOLS[$len_idx]};\n\n            push @len_symbols, $len_idx + 256;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $len - $min);\n            }\n        }\n\n        {\n            my $dist_idx = $DISTANCE_INDICES[$dist];\n            my ($min, $bits) = @{$DISTANCE_SYMBOLS[$dist_idx]};\n\n            push @dist_symbols, $dist_idx;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $dist - $min);\n            }\n        }\n    }\n\n    bz2_compression_symbolic(\\@len_symbols,  $out_fh);\n    bz2_compression_symbolic(\\@dist_symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n}\n\nsub deflate_decode ($fh) {\n\n    my $len_symbols  = bz2_decompression_symbolic($fh);\n    my $dist_symbols = bz2_decompression_symbolic($fh);\n\n    my $bits_len = 0;\n\n    foreach my $i (@$dist_symbols) {\n        $bits_len += $DISTANCE_SYMBOLS[$i][1];\n    }\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            $bits_len += $LENGTH_SYMBOLS[$i - 256][1];\n        }\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @literals;\n    my @lengths;\n    my @distances;\n\n    my $j = 0;\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            my $dist = $dist_symbols->[$j++];\n            push @literals,  undef;\n            push @lengths,   $LENGTH_SYMBOLS[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS[$i - 256][1], ''));\n            push @distances, $DISTANCE_SYMBOLS[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$dist][1], ''));\n        }\n        else {\n            push @literals,  $i;\n            push @lengths,   0;\n            push @distances, 0;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my (@uncompressed, @indices, @lengths);\n        lz77_compression($chunk, \\@uncompressed, \\@indices, \\@lengths);\n\n        my $est_ratio = length($chunk) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices));\n        say scalar(@uncompressed), ' -> ', $est_ratio;\n\n        deflate_encode(\\@uncompressed, \\@indices, \\@lengths, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        my ($uncompressed, $indices, $lengths) = deflate_decode($fh);\n        print $out_fh lz77_decompression($uncompressed, $indices, $lengths);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzss2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 June 2023\n# Edit: 20 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression (LZSS variant) + Huffman coding.\n\n# Encoding the literals and the pointers using a DEFLATE-like approach.\n# This version is memory-friendly, supporting arbitrary large chunk sizes.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max);\nuse POSIX          qw(ceil log2);\n\nuse constant {\n    PKGNAME => 'LZSS2',\n    VERSION => '0.01',\n    FORMAT  => 'lzss2',\n\n    CHUNK_SIZE => 1 << 17,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub find_distance_index ($dist, $distance_symbols) {\n    foreach my $i (0 .. $#{$distance_symbols}) {\n        if ($distance_symbols->[$i][0] > $dist) {\n            return $i - 1;\n        }\n    }\n}\n\nsub make_deflate_symbols ($size) {\n\n    # [distance value, offset bits]\n    my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4);\n\n    until ($DISTANCE_SYMBOLS[-1][0] > $size) {\n        push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n        push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n    }\n\n    # [length, offset bits]\n    my @LENGTH_SYMBOLS = ((map { [$_, 0] } (3 .. 10)));\n\n    {\n        my $delta = 1;\n        until ($LENGTH_SYMBOLS[-1][0] > 163) {\n            push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1];\n            $delta *= 2;\n            push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n            push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n            push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        }\n        push @LENGTH_SYMBOLS, [258, 0];\n    }\n\n    my @LENGTH_INDICES;\n\n    foreach my $i (0 .. $#LENGTH_SYMBOLS) {\n        my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]};\n        foreach my $k ($min .. $min + (1 << $bits) - 1) {\n            $LENGTH_INDICES[$k] = $i;\n        }\n    }\n\n    return (\\@DISTANCE_SYMBOLS, \\@LENGTH_INDICES, \\@LENGTH_SYMBOLS);\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my ($DISTANCE_SYMBOLS, $LENGTH_INDICES, $LENGTH_SYMBOLS) = make_deflate_symbols(length($str));\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    my $min_len = $LENGTH_SYMBOLS->[0][0];\n    my $max_len = $LENGTH_SYMBOLS->[-1][0];\n\n    my %literal_freq;\n    my %distance_freq;\n\n    my $literal_count  = 0;\n    my $distance_count = 0;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n <= $max_len\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        my $dist             = undef;\n        my $enc_bits_len     = 0;\n        my $literal_bits_len = 0;\n\n        if ($n > $min_len) {\n\n            my $distance_index = find_distance_index($la - $p, $DISTANCE_SYMBOLS);\n            $dist = $DISTANCE_SYMBOLS->[$distance_index];\n            $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0))));\n\n            my $len_idx = $LENGTH_INDICES->[$n - 1];\n            my $len     = $LENGTH_SYMBOLS->[$len_idx];\n\n            $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0))));\n\n            my %freq;\n            foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) {\n                ++$freq{$c};\n                $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0))));\n            }\n        }\n\n        if ($n > $min_len and $enc_bits_len < $literal_bits_len) {\n\n            push @$lengths,      $n - 1;\n            push @$indices,      $la - $p;\n            push @$uncompressed, undef;\n\n            ++$distance_count;\n            ++$distance_freq{$dist->[0]};\n\n            ++$literal_count;\n            ++$literal_freq{$LENGTH_INDICES->[$n - 1] + 256};\n\n            $la += $n - 1;\n            $prefix .= substr($token, 0, -1);\n        }\n        else {\n            my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]);\n\n            push @$uncompressed, @bytes;\n            push @$lengths, (0) x scalar(@bytes);\n            push @$indices, (0) x scalar(@bytes);\n\n            ++$literal_freq{$_} for @bytes;\n\n            $literal_count += $n;\n            $la            += $n;\n            $prefix .= $token;\n        }\n    }\n\n    return;\n}\n\nsub lz77_decompression ($literals, $distances, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#$literals) {\n        if ($lengths->[$i] != 0) {\n            $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]);\n            $offset += $lengths->[$i];\n        }\n        else {\n            $chunk .= chr($literals->[$i]);\n            $offset += 1;\n        }\n    }\n\n    return $chunk;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\nsub deflate_encode ($size, $literals, $distances, $lengths, $out_fh) {\n\n    my ($DISTANCE_SYMBOLS, $LENGTH_INDICES, $LENGTH_SYMBOLS) = make_deflate_symbols($size);\n\n    my @len_symbols;\n    my @dist_symbols;\n    my $offset_bits = '';\n\n    foreach my $j (0 .. $#{$literals}) {\n\n        if ($lengths->[$j] == 0) {\n            push @len_symbols, $literals->[$j];\n            next;\n        }\n\n        my $len  = $lengths->[$j];\n        my $dist = $distances->[$j];\n\n        {\n            my $len_idx = $LENGTH_INDICES->[$len];\n            my ($min, $bits) = @{$LENGTH_SYMBOLS->[$len_idx]};\n\n            push @len_symbols, $len_idx + 256;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $len - $min);\n            }\n        }\n\n        {\n            my $dist_idx = find_distance_index($dist, $DISTANCE_SYMBOLS);\n            my ($min, $bits) = @{$DISTANCE_SYMBOLS->[$dist_idx]};\n\n            push @dist_symbols, $dist_idx;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $dist - $min);\n            }\n        }\n    }\n\n    print $out_fh pack('N', $size);\n    create_huffman_entry(\\@len_symbols,  $out_fh);\n    create_huffman_entry(\\@dist_symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n}\n\nsub deflate_decode ($fh) {\n\n    my $size = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4));\n    my ($DISTANCE_SYMBOLS, $LENGTH_INDICES, $LENGTH_SYMBOLS) = make_deflate_symbols($size);\n\n    my $len_symbols  = decode_huffman_entry($fh);\n    my $dist_symbols = decode_huffman_entry($fh);\n\n    my $bits_len = 0;\n\n    foreach my $i (@$dist_symbols) {\n        $bits_len += $DISTANCE_SYMBOLS->[$i][1];\n    }\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            $bits_len += $LENGTH_SYMBOLS->[$i - 256][1];\n        }\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @literals;\n    my @lengths;\n    my @distances;\n\n    my $j = 0;\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            my $dist = $dist_symbols->[$j++];\n            push @literals,  undef;\n            push @lengths,   $LENGTH_SYMBOLS->[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS->[$i - 256][1], ''));\n            push @distances, $DISTANCE_SYMBOLS->[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS->[$dist][1], ''));\n        }\n        else {\n            push @literals,  $i;\n            push @lengths,   0;\n            push @distances, 0;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my (@uncompressed, @indices, @lengths);\n        lz77_compression($chunk, \\@uncompressed, \\@indices, \\@lengths);\n\n        my $est_ratio = length($chunk) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices));\n        say scalar(@uncompressed), ' -> ', $est_ratio;\n\n        deflate_encode(length($chunk), \\@uncompressed, \\@indices, \\@lengths, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        my ($uncompressed, $indices, $lengths) = deflate_decode($fh);\n        print $out_fh lz77_decompression($uncompressed, $indices, $lengths);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzss_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 June 2023\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression (LZSS variant) + Huffman coding.\n\n# Encoding the literals and the pointers using a DEFLATE-like approach.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max);\nuse POSIX          qw(ceil log2);\n\nuse constant {\n    PKGNAME => 'LZSS',\n    VERSION => '0.01',\n    FORMAT  => 'lzss',\n\n    CHUNK_SIZE => 1 << 16,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\n# [distance value, offset bits]\nmy @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4);\n\nuntil ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) {\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n}\n\n# [length, offset bits]\nmy @LENGTH_SYMBOLS = ((map { [$_, 0] } (3 .. 10)));\n\n{\n    my $delta = 1;\n    until ($LENGTH_SYMBOLS[-1][0] > 163) {\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1];\n        $delta *= 2;\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n    }\n    push @LENGTH_SYMBOLS, [258, 0];\n}\n\nmy @DISTANCE_INDICES;\n\nforeach my $i (0 .. $#DISTANCE_SYMBOLS) {\n    my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        last if ($k > CHUNK_SIZE);\n        $DISTANCE_INDICES[$k] = $i;\n    }\n}\n\nmy @LENGTH_INDICES;\n\nforeach my $i (0 .. $#LENGTH_SYMBOLS) {\n    my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        $LENGTH_INDICES[$k] = $i;\n    }\n}\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    my $min_len = $LENGTH_SYMBOLS[0][0];\n    my $max_len = $LENGTH_SYMBOLS[-1][0];\n\n    my %literal_freq;\n    my %distance_freq;\n\n    my $literal_count  = 0;\n    my $distance_count = 0;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n <= $max_len\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        my $enc_bits_len     = 0;\n        my $literal_bits_len = 0;\n\n        if ($n > $min_len) {\n\n            my $dist = $DISTANCE_SYMBOLS[$DISTANCE_INDICES[$la - $p]];\n            $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0))));\n\n            my $len_idx = $LENGTH_INDICES[$n - 1];\n            my $len     = $LENGTH_SYMBOLS[$len_idx];\n\n            $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0))));\n\n            my %freq;\n            foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) {\n                ++$freq{$c};\n                $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0))));\n            }\n        }\n\n        if ($n > $min_len and $enc_bits_len < $literal_bits_len) {\n\n            push @$lengths,      $n - 1;\n            push @$indices,      $la - $p;\n            push @$uncompressed, undef;\n\n            my $dist_idx = $DISTANCE_INDICES[$la - $p];\n            my $dist     = $DISTANCE_SYMBOLS[$dist_idx];\n\n            ++$distance_count;\n            ++$distance_freq{$dist->[0]};\n\n            ++$literal_count;\n            ++$literal_freq{$LENGTH_INDICES[$n - 1] + 256};\n\n            $la += $n - 1;\n            $prefix .= substr($token, 0, -1);\n        }\n        else {\n            my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]);\n\n            push @$uncompressed, @bytes;\n            push @$lengths, (0) x scalar(@bytes);\n            push @$indices, (0) x scalar(@bytes);\n\n            ++$literal_freq{$_} for @bytes;\n\n            $literal_count += $n;\n            $la            += $n;\n            $prefix .= $token;\n        }\n    }\n\n    return;\n}\n\nsub lz77_decompression ($literals, $distances, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#$literals) {\n        if ($lengths->[$i] != 0) {\n            $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]);\n            $offset += $lengths->[$i];\n        }\n        else {\n            $chunk .= chr($literals->[$i]);\n            $offset += 1;\n        }\n    }\n\n    return $chunk;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\nsub deflate_encode ($literals, $distances, $lengths, $out_fh) {\n\n    my @len_symbols;\n    my @dist_symbols;\n    my $offset_bits = '';\n\n    foreach my $j (0 .. $#{$literals}) {\n\n        if ($lengths->[$j] == 0) {\n            push @len_symbols, $literals->[$j];\n            next;\n        }\n\n        my $len  = $lengths->[$j];\n        my $dist = $distances->[$j];\n\n        {\n            my $len_idx = $LENGTH_INDICES[$len];\n            my ($min, $bits) = @{$LENGTH_SYMBOLS[$len_idx]};\n\n            push @len_symbols, $len_idx + 256;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $len - $min);\n            }\n        }\n\n        {\n            my $dist_idx = $DISTANCE_INDICES[$dist];\n            my ($min, $bits) = @{$DISTANCE_SYMBOLS[$dist_idx]};\n\n            push @dist_symbols, $dist_idx;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $dist - $min);\n            }\n        }\n    }\n\n    create_huffman_entry(\\@len_symbols,  $out_fh);\n    create_huffman_entry(\\@dist_symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n}\n\nsub deflate_decode ($fh) {\n\n    my $len_symbols  = decode_huffman_entry($fh);\n    my $dist_symbols = decode_huffman_entry($fh);\n\n    my $bits_len = 0;\n\n    foreach my $i (@$dist_symbols) {\n        $bits_len += $DISTANCE_SYMBOLS[$i][1];\n    }\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            $bits_len += $LENGTH_SYMBOLS[$i - 256][1];\n        }\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @literals;\n    my @lengths;\n    my @distances;\n\n    my $j = 0;\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            my $dist = $dist_symbols->[$j++];\n            push @literals,  undef;\n            push @lengths,   $LENGTH_SYMBOLS[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS[$i - 256][1], ''));\n            push @distances, $DISTANCE_SYMBOLS[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$dist][1], ''));\n        }\n        else {\n            push @literals,  $i;\n            push @lengths,   0;\n            push @distances, 0;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my (@uncompressed, @indices, @lengths);\n        lz77_compression($chunk, \\@uncompressed, \\@indices, \\@lengths);\n\n        my $est_ratio = length($chunk) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices));\n        say scalar(@uncompressed), ' -> ', $est_ratio;\n\n        deflate_encode(\\@uncompressed, \\@indices, \\@lengths, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        my ($uncompressed, $indices, $lengths) = deflate_decode($fh);\n        print $out_fh lz77_decompression($uncompressed, $indices, $lengths);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzssf_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 June 2023\n# Edit: 02 May 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression (LZSS variant with hash tables -- fast version) + Huffman coding.\n\n# Encoding the literals and the pointers using a DEFLATE-like approach.\n# This version is memory-friendly, supporting arbitrary large chunk sizes.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max);\n\nuse constant {\n    PKGNAME => 'LZSSF',\n    VERSION => '0.01',\n    FORMAT  => 'lzssf',\n\n    CHUNK_SIZE => 1 << 17,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub find_distance_index ($dist, $distance_symbols) {\n    foreach my $i (0 .. $#{$distance_symbols}) {\n        if ($distance_symbols->[$i][0] > $dist) {\n            return $i - 1;\n        }\n    }\n}\n\nsub make_deflate_symbols ($size) {\n\n    # [distance value, offset bits]\n    my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4);\n\n    until ($DISTANCE_SYMBOLS[-1][0] > $size) {\n        push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n        push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n    }\n\n    # [length, offset bits]\n    my @LENGTH_SYMBOLS = ((map { [$_, 0] } (4 .. 10)));\n\n    {\n        my $delta = 1;\n        until ($LENGTH_SYMBOLS[-1][0] > 163) {\n            push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1];\n            $delta *= 2;\n            push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n            push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n            push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        }\n        push @LENGTH_SYMBOLS, [258, 0];\n    }\n\n    my @LENGTH_INDICES;\n\n    foreach my $i (0 .. $#LENGTH_SYMBOLS) {\n        my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]};\n        foreach my $k ($min .. $min + (1 << $bits) - 1) {\n            $LENGTH_INDICES[$k] = $i;\n        }\n    }\n\n    return (\\@DISTANCE_SYMBOLS, \\@LENGTH_INDICES, \\@LENGTH_SYMBOLS);\n}\n\nsub lz77_compression($str) {\n\n    my $la = 0;\n\n    my @symbols = unpack('C*', $str);\n    my $end     = $#symbols;\n\n    my $min_len = 4;      # minimum match length\n    my $max_len = 258;    # maximum match length\n\n    my (@literals, @distances, @lengths, %table);\n\n    while ($la <= $end) {\n\n        my $best_n = 1;\n        my $best_p = $la;\n\n        my $lookahead = substr($str, $la, $min_len);\n\n        if (exists($table{$lookahead})) {\n\n            my $p = $table{$lookahead};\n            my $n = $min_len;\n\n            while ($n <= $max_len and $la + $n <= $end and $symbols[$la + $n - 1] == $symbols[$p + $n - 1]) {\n                ++$n;\n            }\n\n            $best_p = $p;\n            $best_n = $n;\n\n            $table{$lookahead} = $la;\n        }\n        else {\n            $table{$lookahead} = $la;\n        }\n\n        if ($best_n > $min_len) {\n\n            push @lengths,   $best_n - 1;\n            push @distances, $la - $best_p;\n            push @literals,  undef;\n\n            $la += $best_n - 1;\n        }\n        else {\n\n            push @lengths,   (0) x $best_n;\n            push @distances, (0) x $best_n;\n            push @literals, @symbols[$best_p .. $best_p + $best_n - 1];\n\n            $la += $best_n;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\nsub lz77_decompression ($literals, $distances, $lengths) {\n\n    my $data     = '';\n    my $data_len = 0;\n\n    foreach my $i (0 .. $#$lengths) {\n\n        if ($lengths->[$i] == 0) {\n            $data .= chr($literals->[$i]);\n            ++$data_len;\n            next;\n        }\n\n        my $length = $lengths->[$i];\n        my $dist   = $distances->[$i];\n\n        if ($dist >= $length) {\n            $data .= substr($data, $data_len - $dist, $length);\n        }\n        elsif ($dist == 1) {\n            $data .= substr($data, -1) x $length;\n        }\n        else {\n            foreach my $i (1 .. $length) {\n                $data .= substr($data, $data_len + $i - $dist - 1, 1);\n            }\n        }\n\n        $data_len += $length;\n    }\n\n    return $data;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\nsub deflate_encode ($size, $literals, $distances, $lengths, $out_fh) {\n\n    my ($DISTANCE_SYMBOLS, $LENGTH_INDICES, $LENGTH_SYMBOLS) = make_deflate_symbols($size);\n\n    my @len_symbols;\n    my @dist_symbols;\n    my $offset_bits = '';\n\n    foreach my $k (0 .. $#{$literals}) {\n\n        if ($lengths->[$k] == 0) {\n            push @len_symbols, $literals->[$k];\n            next;\n        }\n\n        my $len  = $lengths->[$k];\n        my $dist = $distances->[$k];\n\n        {\n            my $len_idx = $LENGTH_INDICES->[$len];\n            my ($min, $bits) = @{$LENGTH_SYMBOLS->[$len_idx]};\n\n            push @len_symbols, $len_idx + 256;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $len - $min);\n            }\n        }\n\n        {\n            my $dist_idx = find_distance_index($dist, $DISTANCE_SYMBOLS);\n            my ($min, $bits) = @{$DISTANCE_SYMBOLS->[$dist_idx]};\n\n            push @dist_symbols, $dist_idx;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $dist - $min);\n            }\n        }\n    }\n\n    print $out_fh pack('N', $size);\n    create_huffman_entry(\\@len_symbols,  $out_fh);\n    create_huffman_entry(\\@dist_symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n}\n\nsub deflate_decode ($fh) {\n\n    my $size = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4));\n    my ($DISTANCE_SYMBOLS, $LENGTH_INDICES, $LENGTH_SYMBOLS) = make_deflate_symbols($size);\n\n    my $len_symbols  = decode_huffman_entry($fh);\n    my $dist_symbols = decode_huffman_entry($fh);\n\n    my $bits_len = 0;\n\n    foreach my $i (@$dist_symbols) {\n        $bits_len += $DISTANCE_SYMBOLS->[$i][1];\n    }\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            $bits_len += $LENGTH_SYMBOLS->[$i - 256][1];\n        }\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @literals;\n    my @lengths;\n    my @distances;\n\n    my $j = 0;\n    my $k = 0;\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            my $dist = $dist_symbols->[$j++];\n            push @literals,  undef;\n            push @lengths,   $LENGTH_SYMBOLS->[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS->[$i - 256][1], ''));\n            push @distances, $DISTANCE_SYMBOLS->[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS->[$dist][1], ''));\n        }\n        else {\n            push @literals,  $i;\n            push @lengths,   0;\n            push @distances, 0;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my ($literals, $distances, $lengths) = lz77_compression($chunk);\n        my $est_ratio = length($chunk) / (scalar(@$literals) + scalar(@$lengths) + 2 * scalar(@$distances));\n        say scalar(@$literals), ' -> ', $est_ratio;\n\n        deflate_encode(length($chunk), $literals, $distances, $lengths, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        my ($literals, $distances, $lengths) = deflate_decode($fh);\n        print $out_fh lz77_decompression($literals, $distances, $lengths);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzsst2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 June 2023\n# Edit: 04 July 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression (LZSS variant with hash tables and lazy matching) + Huffman coding.\n\n# Encoding the literals and the pointers using a DEFLATE-like approach.\n# This version is memory-friendly, supporting arbitrary large chunk sizes.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n#\n#   DEFLATE Compressed Data Format Specification version 1.3\n#   https://datatracker.ietf.org/doc/html/rfc1951\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max);\n\nuse constant {\n    PKGNAME => 'LZSST2',\n    VERSION => '0.01',\n    FORMAT  => 'lzsst2',\n\n    CHUNK_SIZE => 1 << 19,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub find_distance_index ($dist, $distance_symbols) {\n    my ($lo, $hi) = (0, $#{$distance_symbols});\n    while ($lo < $hi) {\n        my $mid = ($lo + $hi + 1) >> 1;\n        if ($distance_symbols->[$mid][0] <= $dist) {\n            $lo = $mid;\n        }\n        else {\n            $hi = $mid - 1;\n        }\n    }\n    return $lo;\n}\n\nsub make_deflate_symbols ($size) {\n\n    # [distance value, offset bits]\n    my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4);\n\n    until ($DISTANCE_SYMBOLS[-1][0] > $size) {\n        push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n        push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n    }\n\n    # [length, offset bits]\n    my @LENGTH_SYMBOLS = ((map { [$_, 0] } (4 .. 10)));\n\n    {\n        my $delta = 1;\n        until ($LENGTH_SYMBOLS[-1][0] > 163) {\n            push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1];\n            $delta *= 2;\n            push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n            push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n            push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        }\n        push @LENGTH_SYMBOLS, [258, 0];\n    }\n\n    my @LENGTH_INDICES;\n\n    foreach my $i (0 .. $#LENGTH_SYMBOLS) {\n        my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]};\n        foreach my $k ($min .. $min + (1 << $bits) - 1) {\n            $LENGTH_INDICES[$k] = $i;\n        }\n    }\n\n    return (\\@DISTANCE_SYMBOLS, \\@LENGTH_INDICES, \\@LENGTH_SYMBOLS);\n}\n\nsub find_match ($str_ref, $la, $min_len, $max_len, $end, $table, $symbols) {\n\n    my $best_n = 1;\n    my $best_p = $la;\n\n    my $lookahead = substr($$str_ref, $la, $min_len);\n\n    if (exists($table->{$lookahead})) {\n\n        foreach my $p (@{$table->{$lookahead}}) {\n\n            my $n = $min_len;\n\n            while ($n <= $max_len and $la + $n <= $end and $symbols->[$la + $n - 1] == $symbols->[$p + $n - 1]) {\n                ++$n;\n            }\n\n            if ($n > $best_n) {\n                $best_p = $p;\n                $best_n = $n;\n                last if ($best_n > $max_len);    # can't do better\n            }\n        }\n    }\n\n    return ($best_n, $best_p);\n}\n\nsub lz77_compression($str) {\n\n    my $la = 0;\n\n    my @symbols = unpack('C*', $str);\n    my $end     = $#symbols;\n\n    my $min_len       = 4;      # minimum match length\n    my $max_len       = 258;    # maximum match length\n    my $max_chain_len = 48;     # how many recent positions to keep track of\n\n    my (@literals, @distances, @lengths, %table);\n\n    while ($la <= $end) {\n\n        my $lookahead1 = substr($str, $la,     $min_len);\n        my $lookahead2 = substr($str, $la + 1, $min_len);\n\n        my ($n1, $p1) = (1, $la);\n        my ($n2, $p2) = (1, $la + 1);\n\n        if (exists($table{$lookahead1})) {\n            ($n1, $p1) = find_match(\\$str, $la, $min_len, $max_len, $end, \\%table, \\@symbols);\n        }\n\n        if ($n1 > 1 and exists($table{$lookahead2})) {\n            ($n2, $p2) = find_match(\\$str, $la + 1, $min_len, $max_len, $end, \\%table, \\@symbols);\n        }\n\n        my $best_n    = $n1;\n        my $best_p    = $p1;\n        my $lookahead = $lookahead1;\n\n        # When a longer match is found at position la+1,\n        # emit a literal followed by the longer match.\n        # https://datatracker.ietf.org/doc/html/rfc1951#section-4\n\n        if ($n2 > $n1 and $p1 < $p2) {\n\n            push @lengths,   (0);\n            push @distances, (0);\n            push @literals, $symbols[$la];\n\n            $la += 1;\n\n            $best_n    = $n2;\n            $best_p    = $p2;\n            $lookahead = $lookahead2;\n        }\n\n        my $matched = substr($str, $la, $best_n);\n\n        foreach my $i (0 .. length($matched) - $min_len) {\n\n            my $key = substr($matched, $i, $min_len);\n            unshift @{$table{$key}}, $la + $i;\n\n            if (scalar(@{$table{$key}}) > $max_chain_len) {\n                pop @{$table{$key}};\n            }\n        }\n\n        if ($best_n == 1) {\n            $table{$lookahead} = [$la];\n        }\n\n        if ($best_n > $min_len) {\n\n            push @lengths,   $best_n - 1;\n            push @distances, $la - $best_p;\n            push @literals,  undef;\n\n            $la += $best_n - 1;\n        }\n        else {\n\n            push @lengths,   (0) x $best_n;\n            push @distances, (0) x $best_n;\n            push @literals, @symbols[$best_p .. $best_p + $best_n - 1];\n\n            $la += $best_n;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\nsub lz77_decompression ($literals, $distances, $lengths) {\n\n    my $data     = '';\n    my $data_len = 0;\n\n    foreach my $i (0 .. $#$lengths) {\n\n        if ($lengths->[$i] == 0) {\n            $data .= chr($literals->[$i]);\n            ++$data_len;\n            next;\n        }\n\n        my $length = $lengths->[$i];\n        my $dist   = $distances->[$i];\n\n        if ($dist >= $length) {    # non-overlapping matches\n            $data .= substr($data, $data_len - $dist, $length);\n        }\n        elsif ($dist == 1) {       # run-length of last character\n            $data .= substr($data, -1) x $length;\n        }\n        else {                     # overlapping matches\n            my $pattern   = substr($data, $data_len - $dist, $dist);\n            my $full_reps = int(($length + $dist - 1) / $dist) + 1;\n            $data .= substr($pattern x $full_reps, 0, $length);\n        }\n\n        $data_len += $length;\n    }\n\n    return $data;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# Heap helpers\n\nsub _heap_push ($heap, $item) {\n    push @$heap, $item;\n    my $i = $#$heap;\n    while ($i > 0) {\n        my $p = ($i - 1) >> 1;\n        last if $heap->[$p][1] <= $heap->[$i][1];\n        @{$heap}[$p, $i] = @{$heap}[$i, $p];\n        $i = $p;\n    }\n}\n\nsub _heap_pop ($heap) {\n    return pop @$heap if @$heap == 1;\n    my $min = $heap->[0];\n    $heap->[0] = pop @$heap;\n    my ($i, $n) = (0, scalar @$heap);\n    while (1) {\n        my ($l, $r, $s) = ($i * 2 + 1, $i * 2 + 2, $i);\n        $s = $l if $l < $n && $heap->[$l][1] < $heap->[$s][1];\n        $s = $r if $r < $n && $heap->[$r][1] < $heap->[$s][1];\n        last if $s == $i;\n        @{$heap}[$i, $s] = @{$heap}[$s, $i];\n        $i = $s;\n    }\n    return $min;\n}\n\nsub mktree_from_freq ($freq) {\n\n    my @heap;\n    _heap_push(\\@heap, [$_, $freq->{$_}]) for sort { $a <=> $b } keys %$freq;\n\n    while (@heap > 1) {\n        my $x = _heap_pop(\\@heap);\n        my $y = _heap_pop(\\@heap);\n        _heap_push(\\@heap, [[$x, $y], $x->[1] + $y->[1]]);\n    }\n\n    walk($heap[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\nsub deflate_encode ($size, $literals, $distances, $lengths, $out_fh) {\n\n    my ($DISTANCE_SYMBOLS, $LENGTH_INDICES, $LENGTH_SYMBOLS) = make_deflate_symbols($size);\n\n    my @len_symbols;\n    my @dist_symbols;\n    my $offset_bits = '';\n\n    foreach my $k (0 .. $#{$literals}) {\n\n        if ($lengths->[$k] == 0) {\n            push @len_symbols, $literals->[$k];\n            next;\n        }\n\n        my $len  = $lengths->[$k];\n        my $dist = $distances->[$k];\n\n        {\n            my $len_idx = $LENGTH_INDICES->[$len];\n            my ($min, $bits) = @{$LENGTH_SYMBOLS->[$len_idx]};\n\n            push @len_symbols, $len_idx + 256;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $len - $min);\n            }\n        }\n\n        {\n            my $dist_idx = find_distance_index($dist, $DISTANCE_SYMBOLS);\n            my ($min, $bits) = @{$DISTANCE_SYMBOLS->[$dist_idx]};\n\n            push @dist_symbols, $dist_idx;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $dist - $min);\n            }\n        }\n    }\n\n    print $out_fh pack('N', $size);\n    create_huffman_entry(\\@len_symbols,  $out_fh);\n    create_huffman_entry(\\@dist_symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n}\n\nsub deflate_decode ($fh) {\n\n    my $size = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4));\n    my ($DISTANCE_SYMBOLS, $LENGTH_INDICES, $LENGTH_SYMBOLS) = make_deflate_symbols($size);\n\n    my $len_symbols  = decode_huffman_entry($fh);\n    my $dist_symbols = decode_huffman_entry($fh);\n\n    my $bits_len = 0;\n\n    foreach my $i (@$dist_symbols) {\n        $bits_len += $DISTANCE_SYMBOLS->[$i][1];\n    }\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            $bits_len += $LENGTH_SYMBOLS->[$i - 256][1];\n        }\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @literals;\n    my @lengths;\n    my @distances;\n\n    my $j = 0;\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            my $dist = $dist_symbols->[$j++];\n            push @literals,  undef;\n            push @lengths,   $LENGTH_SYMBOLS->[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS->[$i - 256][1], ''));\n            push @distances, $DISTANCE_SYMBOLS->[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS->[$dist][1], ''));\n        }\n        else {\n            push @literals,  $i;\n            push @lengths,   0;\n            push @distances, 0;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my ($literals, $distances, $lengths) = lz77_compression($chunk);\n        my $est_ratio = length($chunk) / (scalar(@$literals) + scalar(@$lengths) + 2 * scalar(@$distances));\n        say scalar(@$literals), ' -> ', $est_ratio;\n\n        deflate_encode(length($chunk), $literals, $distances, $lengths, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        my ($literals, $distances, $lengths) = deflate_decode($fh);\n        print $out_fh lz77_decompression($literals, $distances, $lengths);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzsst_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 June 2023\n# Edit: 02 May 2024\n# https://github.com/trizen\n\n# Compress/decompress files using LZ77 compression (LZSS variant with hash tables) + Huffman coding.\n\n# Encoding the literals and the pointers using a DEFLATE-like approach.\n# This version is memory-friendly, supporting arbitrary large chunk sizes.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max);\n\nuse constant {\n    PKGNAME => 'LZSST',\n    VERSION => '0.01',\n    FORMAT  => 'lzsst',\n\n    CHUNK_SIZE => 1 << 19,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub find_distance_index ($dist, $distance_symbols) {\n    foreach my $i (0 .. $#{$distance_symbols}) {\n        if ($distance_symbols->[$i][0] > $dist) {\n            return $i - 1;\n        }\n    }\n}\n\nsub make_deflate_symbols ($size) {\n\n    # [distance value, offset bits]\n    my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4);\n\n    until ($DISTANCE_SYMBOLS[-1][0] > $size) {\n        push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n        push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n    }\n\n    # [length, offset bits]\n    my @LENGTH_SYMBOLS = ((map { [$_, 0] } (4 .. 10)));\n\n    {\n        my $delta = 1;\n        until ($LENGTH_SYMBOLS[-1][0] > 163) {\n            push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1];\n            $delta *= 2;\n            push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n            push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n            push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        }\n        push @LENGTH_SYMBOLS, [258, 0];\n    }\n\n    my @LENGTH_INDICES;\n\n    foreach my $i (0 .. $#LENGTH_SYMBOLS) {\n        my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]};\n        foreach my $k ($min .. $min + (1 << $bits) - 1) {\n            $LENGTH_INDICES[$k] = $i;\n        }\n    }\n\n    return (\\@DISTANCE_SYMBOLS, \\@LENGTH_INDICES, \\@LENGTH_SYMBOLS);\n}\n\nsub lz77_compression($str) {\n\n    my $la = 0;\n\n    my @symbols = unpack('C*', $str);\n    my $end     = $#symbols;\n\n    my $min_len       = 4;      # minimum match length\n    my $max_len       = 258;    # maximum match length\n    my $max_chain_len = 48;     # how many recent positions to keep track of\n\n    my (@literals, @distances, @lengths, %table);\n\n    while ($la <= $end) {\n\n        my $best_n = 1;\n        my $best_p = $la;\n\n        my $lookahead = substr($str, $la, $min_len);\n\n        if (exists($table{$lookahead})) {\n\n            foreach my $p (@{$table{$lookahead}}) {\n\n                my $n = $min_len;\n\n                while ($n <= $max_len and $la + $n <= $end and $symbols[$la + $n - 1] == $symbols[$p + $n - 1]) {\n                    ++$n;\n                }\n\n                if ($n > $best_n) {\n                    $best_p = $p;\n                    $best_n = $n;\n                }\n            }\n\n            my $matched = substr($str, $la, $best_n);\n\n            foreach my $i (0 .. length($matched) - $min_len) {\n\n                my $key = substr($matched, $i, $min_len);\n                unshift @{$table{$key}}, $la + $i;\n\n                if (scalar(@{$table{$key}}) > $max_chain_len) {\n                    pop @{$table{$key}};\n                }\n            }\n        }\n\n        if ($best_n == 1) {\n            $table{$lookahead} = [$la];\n        }\n\n        if ($best_n > $min_len) {\n\n            push @lengths,   $best_n - 1;\n            push @distances, $la - $best_p;\n            push @literals,  undef;\n\n            $la += $best_n - 1;\n        }\n        else {\n\n            push @lengths,   (0) x $best_n;\n            push @distances, (0) x $best_n;\n            push @literals, @symbols[$best_p .. $best_p + $best_n - 1];\n\n            $la += $best_n;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\nsub lz77_decompression ($literals, $distances, $lengths) {\n\n    my $data     = '';\n    my $data_len = 0;\n\n    foreach my $i (0 .. $#$lengths) {\n\n        if ($lengths->[$i] == 0) {\n            $data .= chr($literals->[$i]);\n            ++$data_len;\n            next;\n        }\n\n        my $length = $lengths->[$i];\n        my $dist   = $distances->[$i];\n\n        if ($dist >= $length) {    # non-overlapping matches\n            $data .= substr($data, $data_len - $dist, $length);\n        }\n        elsif ($dist == 1) {       # run-length of last character\n            $data .= substr($data, -1) x $length;\n        }\n        else {                     # overlapping matches\n            foreach my $i (1 .. $length) {\n                $data .= substr($data, $data_len + $i - $dist - 1, 1);\n            }\n        }\n\n        $data_len += $length;\n    }\n\n    return $data;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\nsub deflate_encode ($size, $literals, $distances, $lengths, $out_fh) {\n\n    my ($DISTANCE_SYMBOLS, $LENGTH_INDICES, $LENGTH_SYMBOLS) = make_deflate_symbols($size);\n\n    my @len_symbols;\n    my @dist_symbols;\n    my $offset_bits = '';\n\n    foreach my $k (0 .. $#{$literals}) {\n\n        if ($lengths->[$k] == 0) {\n            push @len_symbols, $literals->[$k];\n            next;\n        }\n\n        my $len  = $lengths->[$k];\n        my $dist = $distances->[$k];\n\n        {\n            my $len_idx = $LENGTH_INDICES->[$len];\n            my ($min, $bits) = @{$LENGTH_SYMBOLS->[$len_idx]};\n\n            push @len_symbols, $len_idx + 256;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $len - $min);\n            }\n        }\n\n        {\n            my $dist_idx = find_distance_index($dist, $DISTANCE_SYMBOLS);\n            my ($min, $bits) = @{$DISTANCE_SYMBOLS->[$dist_idx]};\n\n            push @dist_symbols, $dist_idx;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $dist - $min);\n            }\n        }\n    }\n\n    print $out_fh pack('N', $size);\n    create_huffman_entry(\\@len_symbols,  $out_fh);\n    create_huffman_entry(\\@dist_symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n}\n\nsub deflate_decode ($fh) {\n\n    my $size = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4));\n    my ($DISTANCE_SYMBOLS, $LENGTH_INDICES, $LENGTH_SYMBOLS) = make_deflate_symbols($size);\n\n    my $len_symbols  = decode_huffman_entry($fh);\n    my $dist_symbols = decode_huffman_entry($fh);\n\n    my $bits_len = 0;\n\n    foreach my $i (@$dist_symbols) {\n        $bits_len += $DISTANCE_SYMBOLS->[$i][1];\n    }\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            $bits_len += $LENGTH_SYMBOLS->[$i - 256][1];\n        }\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @literals;\n    my @lengths;\n    my @distances;\n\n    my $j = 0;\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            my $dist = $dist_symbols->[$j++];\n            push @literals,  undef;\n            push @lengths,   $LENGTH_SYMBOLS->[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS->[$i - 256][1], ''));\n            push @distances, $DISTANCE_SYMBOLS->[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS->[$dist][1], ''));\n        }\n        else {\n            push @literals,  $i;\n            push @lengths,   0;\n            push @distances, 0;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my ($literals, $distances, $lengths) = lz77_compression($chunk);\n        my $est_ratio = length($chunk) / (scalar(@$literals) + scalar(@$lengths) + 2 * scalar(@$distances));\n        say scalar(@$literals), ' -> ', $est_ratio;\n\n        deflate_encode(length($chunk), $literals, $distances, $lengths, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        my ($literals, $distances, $lengths) = deflate_decode($fh);\n        print $out_fh lz77_decompression($literals, $distances, $lengths);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzt2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Created on: 21 May 2014\n# Latest edit on: 28 May 2014\n# Website: https://github.com/trizen\n\n# A new type of LZ compression, featuring a very short decompression time.\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\n\nuse constant {\n              PKGNAME => 'lzt2',\n              VERSION => '0.01',\n              FORMAT  => 'lzt2',\n             };\n\nuse constant {\n              MIN       => 9,\n              BUFFER    => 2**16,\n              SIGNATURE => uc(FORMAT) . chr(1),\n             };\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub compress {\n    my ($input, $output) = @_;\n\n    # Open the input file\n    open my $fh, '<:raw', $input;\n\n    # Open the output file and write the archive signature\n    open my $out_fh, '>:raw', $output;\n    print {$out_fh} SIGNATURE;\n\n    while ((my $len = read($fh, (my $block), BUFFER)) > 0) {\n\n        my %dict;\n        foreach my $i (reverse(MIN .. 255)) {\n            for (my $lim = $len - $i * 2, my $j = 0 ; $j <= $lim ; $j++) {\n                if ((my $pos = index($block, substr($block, $j, $i), $j + $i)) != -1) {\n                    if (not exists $dict{$pos} or $i > $dict{$pos}[1]) {\n                        $dict{$pos} = [$j, $i];\n                    }\n                }\n                else {\n                    $j += int($i / MIN) - 1;\n                }\n            }\n        }\n\n        my @pairs;\n        my $last_pos     = 0;\n        my $uncompressed = '';\n\n        for (my $i = 0 ; $i < $len ; $i++, $last_pos++) {\n            if (exists $dict{$i}) {\n                my ($key, $vlen) = @{$dict{$i}};\n                push @pairs, [$last_pos, $key, $vlen];\n                $i += $vlen - 1;\n                $last_pos = 0;\n            }\n            else {\n                $uncompressed .= substr($block, $i, 1);\n            }\n        }\n\n        my $uncomp_len = length($uncompressed);\n        printf(\"%3d -> %3d (%.2f%%)\\n\", $len, $uncomp_len, ($len - $uncomp_len) / $len * 100);\n        print {$out_fh} pack('S', $uncomp_len - 1), pack('S', scalar @pairs), (map { pack('SSC', @{$_}) } @pairs), $uncompressed;\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nsub decompress {\n    my ($input, $output) = @_;\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input;\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output;\n\n    while (read($fh, (my $len_byte), 2) > 0) {\n        read($fh, (my $groups_byte), 2);\n\n        my @dict;\n        for my $i (1 .. unpack('S', $groups_byte)) {\n            read($fh, (my $positions), 5);\n            push @dict, [unpack('SSC', $positions)];\n        }\n\n        my $len = unpack('S', $len_byte) + 1;\n        read($fh, (my $block), $len);\n\n        my $last_pos     = 0;\n        my $decompressed = '';\n\n        for (my $i = 0 ; $i <= $len ; $i++) {\n            if (@dict and ($i - $last_pos == $dict[0][0])) {\n                $decompressed .= substr($decompressed, $dict[0][1], $dict[0][2]);\n                $last_pos = --$i;\n                shift @dict;\n            }\n            else {\n                $decompressed .= substr($block, $i, 1);\n            }\n        }\n\n        print {$out_fh} $decompressed;\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzt_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Created on: 21 May 2014\n# Latest edit on: 28 May 2014\n# Website: https://github.com/trizen\n\n# A new type of LZ compression, featuring a very short decompression time.\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\n\nuse constant {\n              PKGNAME => 'lzt',\n              VERSION => '0.01',\n              FORMAT  => 'lzt',\n             };\n\nuse constant {\n              MIN       => 4,\n              BUFFER    => 256,\n              SIGNATURE => uc(FORMAT) . chr(1),\n             };\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub compress {\n    my ($input, $output) = @_;\n\n    # Open the input file\n    open my $fh, '<:raw', $input;\n\n    # Open the output file and write the archive signature\n    open my $out_fh, '>:raw', $output;\n    print {$out_fh} SIGNATURE;\n\n    while ((my $len = read($fh, (my $block), BUFFER)) > 0) {\n\n        my %dict;\n        foreach my $i (reverse(MIN .. int($len / 2))) {\n            foreach my $j (0 .. $len - $i * 2) {\n                if ((my $pos = index($block, substr($block, $j, $i), $j + $i)) != -1) {\n                    if (not exists $dict{$pos} or $i > $dict{$pos}[1]) {\n                        $dict{$pos} = [$j, $i];\n                    }\n                }\n            }\n        }\n\n        my @pairs;\n        my $last_pos     = 0;\n        my $uncompressed = '';\n\n        for (my $i = 0 ; $i < $len ; $i++, $last_pos++) {\n            if (exists $dict{$i}) {\n                my ($key, $vlen) = @{$dict{$i}};\n                push @pairs, [$last_pos, $key, $vlen];\n                $i += $vlen - 1;\n                $last_pos = 0;\n            }\n            else {\n                $uncompressed .= substr($block, $i, 1);\n            }\n        }\n\n        my $uncomp_len = length($uncompressed);\n        printf(\"%3d -> %3d (%.2f%%)\\n\", $len, $uncomp_len, ($len - $uncomp_len) / $len * 100);\n        print {$out_fh} chr($uncomp_len - 1), chr(scalar @pairs), (\n            map {\n                map { chr }\n                  @{$_}\n              } @pairs\n        ), $uncompressed;\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nsub decompress {\n    my ($input, $output) = @_;\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input;\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output;\n\n    while (read($fh, (my $len_byte), 1) > 0) {\n        read($fh, (my $groups_byte), 1);\n\n        my @dict;\n        for my $i (1 .. ord($groups_byte)) {\n            read($fh, (my $at_byte),   1);\n            read($fh, (my $from_byte), 1);\n            read($fh, (my $size_byte), 1);\n            push @dict, [ord($at_byte), ord($from_byte), ord($size_byte)];\n        }\n\n        my $len = ord($len_byte) + 1;\n        read($fh, (my $block), $len);\n\n        my $last_pos     = 0;\n        my $decompressed = '';\n\n        for (my $i = 0 ; $i <= $len ; $i++) {\n            if (@dict and ($i - $last_pos == $dict[0][0])) {\n                $decompressed .= substr($decompressed, $dict[0][1], $dict[0][2]);\n                $last_pos = --$i;\n                shift @dict;\n            }\n            else {\n                $decompressed .= substr($block, $i, 1);\n            }\n        }\n\n        print {$out_fh} $decompressed;\n    }\n\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/lzw_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 08 December 2022\n# Edit: 15 June 2023\n# https://github.com/trizen\n\n# Compress/decompress files using LZW compression.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Lempel%E2%80%93Ziv%E2%80%93Welch\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\n\nuse constant {\n    PKGNAME => 'LZW',\n    VERSION => '0.03',\n    FORMAT  => 'lzw',\n\n    CHUNK_SIZE => 1 << 17,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(3);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\n# Compress a string to a list of output symbols\nsub compress ($uncompressed) {\n\n    # Build the dictionary\n    my $dict_size = 256;\n    my %dictionary;\n\n    foreach my $i (0 .. $dict_size - 1) {\n        $dictionary{chr($i)} = $i;\n    }\n\n    my $w = '';\n    my @result;\n\n    foreach my $c (split(//, $uncompressed)) {\n        my $wc = $w . $c;\n        if (exists $dictionary{$wc}) {\n            $w = $wc;\n        }\n        else {\n            push @result, $dictionary{$w};\n\n            # Add wc to the dictionary\n            $dictionary{$wc} = $dict_size++;\n            $w = $c;\n        }\n    }\n\n    # Output the code for w\n    if ($w ne '') {\n        push @result, $dictionary{$w};\n    }\n\n    return \\@result;\n}\n\n# Decompress a list of output ks to a string\nsub decompress ($compressed) {\n\n    # Build the dictionary\n    my $dict_size  = 256;\n    my @dictionary = map { chr($_) } 0 .. $dict_size - 1;\n\n    my $w      = $dictionary[$compressed->[0]];\n    my $result = $w;\n\n    foreach my $j (1 .. $#{$compressed}) {\n        my $k = $compressed->[$j];\n\n        my $entry =\n            ($k < $dict_size)  ? $dictionary[$k]\n          : ($k == $dict_size) ? ($w . substr($w, 0, 1))\n          :                      die \"Bad compressed k: $k\";\n\n        $result .= $entry;\n\n        # Add w+entry[0] to the dictionary\n        push @dictionary, $w . substr($entry, 0, 1);\n        ++$dict_size;\n        $w = $entry;\n    }\n\n    return \\$result;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub elias_encoding ($integers) {\n\n    my $bitstring = '';\n    foreach my $k (scalar(@$integers), @$integers) {\n        if ($k == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', $k);\n            my $l = length($t) + 1;\n            my $L = sprintf('%b', $l);\n            $bitstring .= ('1' x (length($L) - 1)) . '0' . substr($L, 1) . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub elias_decoding ($fh) {\n\n    my @ints;\n    my $len    = 0;\n    my $buffer = '';\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n\n        my $bl = 0;\n        ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n        if ($bl > 0) {\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl)) - 1;\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @ints, $int;\n        }\n        else {\n            push @ints, 0;\n        }\n\n        if ($k == 0) {\n            $len = pop(@ints);\n        }\n    }\n\n    return \\@ints;\n}\n\nsub encode_integers ($integers) {\n\n    my @counts;\n    my $count           = 0;\n    my $bits_width      = 1;\n    my $bits_max_symbol = 1 << $bits_width;\n    my $processed_len   = 0;\n\n    foreach my $k (@$integers) {\n        while ($k >= $bits_max_symbol) {\n\n            if ($count > 0) {\n                push @counts, [$bits_width, $count];\n                $processed_len += $count;\n            }\n\n            $count = 0;\n            $bits_max_symbol *= 2;\n            $bits_width      += 1;\n        }\n        ++$count;\n    }\n\n    push @counts, grep { $_->[1] > 0 } [$bits_width, scalar(@$integers) - $processed_len];\n\n    say \"Bit sizes: \", join(' ', map { $_->[0] } @counts);\n    say \"Lengths  : \", join(' ', map { $_->[1] } @counts);\n    say '';\n\n    my $compressed = elias_encoding([(map { $_->[0] } @counts), (map { $_->[1] } @counts)]);\n\n    my $bits = '';\n    foreach my $pair (@counts) {\n        my ($blen, $len) = @$pair;\n        foreach my $symbol (splice(@$integers, 0, $len)) {\n            $bits .= sprintf(\"%0*b\", $blen, $symbol);\n        }\n    }\n\n    $compressed .= pack('B*', $bits);\n    return $compressed;\n}\n\nsub decode_integers ($fh) {\n\n    my $ints = elias_decoding($fh);\n    my $half = scalar(@$ints) >> 1;\n\n    my @counts;\n    foreach my $i (0 .. ($half - 1)) {\n        push @counts, [$ints->[$i], $ints->[$half + $i]];\n    }\n\n    my $bits_len = 0;\n\n    foreach my $pair (@counts) {\n        my ($blen, $len) = @$pair;\n        $bits_len += $blen * $len;\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @integers;\n    foreach my $pair (@counts) {\n        my ($blen, $len) = @$pair;\n        foreach my $chunk (unpack(sprintf('(a%d)*', $blen), substr($bits, 0, $blen * $len, ''))) {\n            push @integers, oct('0b' . $chunk);\n        }\n    }\n\n    return \\@integers;\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh encode_integers(compress($chunk));\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        print $out_fh ${decompress(decode_integers($fh))};\n    }\n\n    # Close the output file\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/mbwr_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 14 June 2023\n# Edit: 19 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Move-to-Front Transform (MTF) + Burrows-Wheeler Transform (BWT) + Run-length encoding (RLE) + Huffman coding.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\n\nuse constant {\n    PKGNAME => 'MBWR',\n    VERSION => '0.01',\n    FORMAT  => 'mbwr',\n\n    CHUNK_SIZE    => 1 << 17,\n    LOOKAHEAD_LEN => 128,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for (0, 1) }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n    say \"Max symbol: $max_symbol\\n\";\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    say \"Encoded length: $enc_len\\n\";\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n    my $len = length($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        if ($enc == 0) {\n            $populated <<= 1;\n        }\n        else {\n            ($populated <<= 1) |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta);\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh))));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my $rle4 = do {\n        my @bytes        = unpack('C*', $chunk);\n        my @alphabet     = sort { $a <=> $b } uniq(@bytes);\n        my $alphabet_enc = encode_alphabet(\\@alphabet);\n\n        print $out_fh $alphabet_enc;\n        my $mtf = mtf_encode(\\@bytes, [@alphabet]);\n        rle4_encode($mtf);\n    };\n\n    my ($bwt, $idx) = bwt_encode(pack('C*', @$rle4));\n\n    say \"BWT index = $idx\";\n\n    my @bytes        = unpack('C*', $bwt);\n    my @alphabet     = sort { $a <=> $b } uniq(@bytes);\n    my $alphabet_enc = encode_alphabet(\\@alphabet);\n\n    my $mtf = mtf_encode(\\@bytes, [@alphabet]);\n    my $rle = rle_encode($mtf);\n\n    print $out_fh pack('N', $idx);\n    print $out_fh $alphabet_enc;\n    create_huffman_entry($rle, $out_fh);\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $alphabet2 = decode_alphabet($fh);\n    my $idx       = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4));\n    my $alphabet1 = decode_alphabet($fh);\n\n    say \"BWT index = $idx\";\n    say \"Alphabet size: \", scalar(@$alphabet1);\n\n    my $rle  = decode_huffman_entry($fh);\n    my $mtf  = rle_decode($rle);\n    my $bwt  = mtf_decode($mtf, $alphabet1);\n    my $rle4 = bwt_decode(pack('C*', @$bwt), $idx);\n    my $mtf2 = rle4_decode([unpack('C*', $rle4)]);\n    my $data = mtf_decode($mtf2, $alphabet2);\n\n    print $out_fh pack('C*', @$data);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/mra_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 14 June 2023\n# Edit: 29 February 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Move-to-Front Transform + Run-length encoding + Arithmetic Coding.\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\n\nuse constant {\n    PKGNAME => 'MRA',\n    VERSION => '0.01',\n    FORMAT  => 'mra',\n\n    CHUNK_SIZE => 1 << 17,\n};\n\n# Arithmetic Coding settings\nuse constant BITS => 32;\nuse constant MAX  => oct('0b' . ('1' x BITS));\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(3);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub create_cfreq ($freq) {\n\n    my @cf;\n    my $T = 0;\n\n    foreach my $i (sort { $a <=> $b } keys %$freq) {\n        $freq->{$i} // next;\n        $cf[$i] = $T;\n        $T += $freq->{$i};\n        $cf[$i + 1] = $T;\n    }\n\n    return (\\@cf, $T);\n}\n\nsub ac_encode ($bytes_arr) {\n\n    my $enc        = '';\n    my $EOF_SYMBOL = (max(@$bytes_arr) // 0) + 1;\n    my @bytes      = (@$bytes_arr, $EOF_SYMBOL);\n\n    my %freq;\n    ++$freq{$_} for @bytes;\n\n    my ($cf, $T) = create_cfreq(\\%freq);\n\n    if ($T > MAX) {\n        die \"Too few bits: $T > ${\\MAX}\";\n    }\n\n    my $low      = 0;\n    my $high     = MAX;\n    my $uf_count = 0;\n\n    foreach my $c (@bytes) {\n\n        my $w = $high - $low + 1;\n\n        $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$c]) / $T)) & MAX;\n\n        if ($high > MAX) {\n            die \"high > MAX: $high > ${\\MAX}\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n\n                my $bit = $high >> (BITS - 1);\n                $enc .= $bit;\n\n                if ($uf_count > 0) {\n                    $enc .= join('', 1 - $bit) x $uf_count;\n                    $uf_count = 0;\n                }\n\n                $low <<= 1;\n                ($high <<= 1) |= 1;\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                ++$uf_count;\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n        }\n    }\n\n    $enc .= '0';\n    $enc .= '1';\n\n    while (length($enc) % 8 != 0) {\n        $enc .= '1';\n    }\n\n    return ($enc, \\%freq);\n}\n\nsub ac_decode ($fh, $freq) {\n\n    my ($cf, $T) = create_cfreq($freq);\n\n    my @dec;\n    my $low  = 0;\n    my $high = MAX;\n    my $enc  = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS);\n\n    my @table;\n    foreach my $i (sort { $a <=> $b } keys %$freq) {\n        foreach my $j ($cf->[$i] .. $cf->[$i + 1] - 1) {\n            $table[$j] = $i;\n        }\n    }\n\n    my $EOF_SYMBOL = max(keys %$freq) // 0;\n\n    while (1) {\n\n        my $w  = $high - $low + 1;\n        my $ss = int((($T * ($enc - $low + 1)) - 1) / $w);\n\n        my $i = $table[$ss] // last;\n        last if ($i == $EOF_SYMBOL);\n\n        push @dec, $i;\n\n        $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$i]) / $T)) & MAX;\n\n        if ($high > MAX) {\n            die \"error\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n                ($high <<= 1) |= 1;\n                $low <<= 1;\n                ($enc <<= 1) |= (getc($fh) // 1);\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1);\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n            $enc  &= MAX;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub create_ac_entry ($bytes, $out_fh) {\n\n    my ($enc, $freq) = ac_encode($bytes);\n    my $max_symbol = max(keys %$freq) // 0;\n\n    my @freqs;\n    foreach my $k (0 .. $max_symbol) {\n        push @freqs, $freq->{$k} // 0;\n    }\n\n    push @freqs, length($enc) >> 3;\n\n    say \"Max symbol: $max_symbol\\n\";\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_ac_entry ($fh) {\n\n    my @freqs    = @{delta_decode($fh)};\n    my $bits_len = pop(@freqs);\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    say \"Encoded length: $bits_len\\n\";\n    my $bits = read_bits($fh, $bits_len << 3);\n\n    if ($bits_len > 0) {\n        open my $bits_fh, '<:raw', \\$bits;\n        return ac_decode($bits_fh, \\%freq);\n    }\n\n    return [];\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 254 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        if ($enc == 0) {\n            $populated <<= 1;\n        }\n        else {\n            ($populated <<= 1) |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta);\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh))));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my $bytes        = [unpack('C*', $chunk)];\n    my @alphabet     = sort { $a <=> $b } uniq(@$bytes);\n    my $alphabet_enc = encode_alphabet(\\@alphabet);\n\n    $bytes = mtf_encode($bytes, [@alphabet]);\n    $bytes = rle_encode($bytes);\n    $bytes = rle4_encode($bytes);\n\n    print $out_fh $alphabet_enc;\n    create_ac_entry($bytes, $out_fh);\n}\n\nsub decompression ($fh, $out_fh) {\n    my $alphabet = decode_alphabet($fh);\n    say \"Alphabet size: \", scalar(@$alphabet);\n\n    my $bytes = decode_ac_entry($fh);\n    $bytes = rle4_decode($bytes);\n    $bytes = rle_decode($bytes);\n    $bytes = mtf_decode($bytes, [@$alphabet]);\n\n    print $out_fh pack('C*', @$bytes);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/mrh_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 14 June 2023\n# Edit: 15 August 2023\n# https://github.com/trizen\n\n# Compress/decompress files using Move-to-Front Transform + Run-length encoding + Huffman coding.\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\n\nuse constant {\n    PKGNAME => 'MRH',\n    VERSION => '0.03',\n    FORMAT  => 'mrh',\n\n    CHUNK_SIZE => 1 << 16,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(3);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n    say \"Max symbol: $max_symbol\\n\";\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    say \"Encoded length: $enc_len\\n\";\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 254 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub rle_encode ($bytes) {    # RLE2\n\n    my @rle;\n    my $end = $#{$bytes};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        my $run = 0;\n        while ($i <= $end and $bytes->[$i] == 0) {\n            ++$run;\n            ++$i;\n        }\n\n        if ($run >= 1) {\n            my $t = sprintf('%b', $run + 1);\n            push @rle, split(//, substr($t, 1));\n        }\n\n        if ($i <= $end) {\n            push @rle, $bytes->[$i] + 1;\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle_decode ($rle) {    # RLE2\n\n    my @dec;\n    my $end = $#{$rle};\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n        my $k = $rle->[$i];\n\n        if ($k == 0 or $k == 1) {\n            my $run = 1;\n            while (($i <= $end) and ($k == 0 or $k == 1)) {\n                ($run <<= 1) |= $k;\n                $k = $rle->[++$i];\n            }\n            push @dec, (0) x ($run - 1);\n        }\n\n        if ($i <= $end) {\n            push @dec, $k - 1;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        if ($enc == 0) {\n            $populated <<= 1;\n        }\n        else {\n            ($populated <<= 1) |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta);\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh) // die \"error\")));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my $bytes        = [unpack('C*', $chunk)];\n    my @alphabet     = sort { $a <=> $b } uniq(@$bytes);\n    my $alphabet_enc = encode_alphabet(\\@alphabet);\n\n    $bytes = mtf_encode($bytes, [@alphabet]);\n    $bytes = rle_encode($bytes);\n    $bytes = rle4_encode($bytes);\n\n    print $out_fh $alphabet_enc;\n    create_huffman_entry($bytes, $out_fh);\n}\n\nsub decompression ($fh, $out_fh) {\n    my $alphabet = decode_alphabet($fh);\n    say \"Alphabet size: \", scalar(@$alphabet);\n\n    my $bytes = decode_huffman_entry($fh);\n    $bytes = rle4_decode($bytes);\n    $bytes = rle_decode($bytes);\n    $bytes = mtf_decode($bytes, [@$alphabet]);\n\n    print $out_fh pack('C*', @$bytes);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/mrlz_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 June 2023\n# Edit: 19 March 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Move to Front transform (MTF) + RLE4 + LZ77 compression (LZSS variant) + Huffman coding.\n\n# Encoding the literals and the pointers using a DEFLATE-like approach.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\nuse POSIX          qw(ceil log2);\n\nuse constant {\n    PKGNAME => 'MRLZ',\n    VERSION => '0.01',\n    FORMAT  => 'mrlz',\n\n    CHUNK_SIZE => 1 << 16,    # higher value = better compression\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\n# [distance value, offset bits]\nmy @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4);\n\nuntil ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) {\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n}\n\n# [length, offset bits]\nmy @LENGTH_SYMBOLS = ((map { [$_, 0] } (3 .. 10)));\n\n{\n    my $delta = 1;\n    until ($LENGTH_SYMBOLS[-1][0] > 163) {\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1];\n        $delta *= 2;\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n        push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]];\n    }\n    push @LENGTH_SYMBOLS, [258, 0];\n}\n\nmy @DISTANCE_INDICES;\n\nforeach my $i (0 .. $#DISTANCE_SYMBOLS) {\n    my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        last if ($k > CHUNK_SIZE);\n        $DISTANCE_INDICES[$k] = $i;\n    }\n}\n\nmy @LENGTH_INDICES;\n\nforeach my $i (0 .. $#LENGTH_SYMBOLS) {\n    my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]};\n    foreach my $k ($min .. $min + (1 << $bits) - 1) {\n        $LENGTH_INDICES[$k] = $i;\n    }\n}\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub lz77_compression ($str, $uncompressed, $indices, $lengths) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    my $min_len = $LENGTH_SYMBOLS[0][0];\n    my $max_len = $LENGTH_SYMBOLS[-1][0];\n\n    my %literal_freq;\n    my %distance_freq;\n\n    my $literal_count  = 0;\n    my $distance_count = 0;\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n <= $max_len\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        my $enc_bits_len     = 0;\n        my $literal_bits_len = 0;\n\n        if ($n > $min_len) {\n\n            my $dist = $DISTANCE_SYMBOLS[$DISTANCE_INDICES[$la - $p]];\n            $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0))));\n\n            my $len_idx = $LENGTH_INDICES[$n - 1];\n            my $len     = $LENGTH_SYMBOLS[$len_idx];\n\n            $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0))));\n\n            my %freq;\n            foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) {\n                ++$freq{$c};\n                $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0))));\n            }\n        }\n\n        if ($n > $min_len and $enc_bits_len < $literal_bits_len) {\n\n            push @$lengths,      $n - 1;\n            push @$indices,      $la - $p;\n            push @$uncompressed, undef;\n\n            my $dist_idx = $DISTANCE_INDICES[$la - $p];\n            my $dist     = $DISTANCE_SYMBOLS[$dist_idx];\n\n            ++$distance_count;\n            ++$distance_freq{$dist->[0]};\n\n            ++$literal_count;\n            ++$literal_freq{$LENGTH_INDICES[$n - 1] + 256};\n\n            $la += $n - 1;\n            $prefix .= substr($token, 0, -1);\n        }\n        else {\n            my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]);\n\n            push @$uncompressed, @bytes;\n            push @$lengths, (0) x scalar(@bytes);\n            push @$indices, (0) x scalar(@bytes);\n\n            ++$literal_freq{$_} for @bytes;\n\n            $literal_count += $n;\n            $la            += $n;\n            $prefix .= $token;\n        }\n    }\n\n    return;\n}\n\nsub lz77_decompression ($literals, $distances, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#$literals) {\n        if ($lengths->[$i] != 0) {\n            $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]);\n            $offset += $lengths->[$i];\n        }\n        else {\n            $chunk .= chr($literals->[$i]);\n            $offset += 1;\n        }\n    }\n\n    return $chunk;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\nsub deflate_encode ($literals, $distances, $lengths, $out_fh) {\n\n    my @len_symbols;\n    my @dist_symbols;\n    my $offset_bits = '';\n\n    foreach my $j (0 .. $#{$literals}) {\n\n        if ($lengths->[$j] == 0) {\n            push @len_symbols, $literals->[$j];\n            next;\n        }\n\n        my $len  = $lengths->[$j];\n        my $dist = $distances->[$j];\n\n        {\n            my $len_idx = $LENGTH_INDICES[$len];\n            my ($min, $bits) = @{$LENGTH_SYMBOLS[$len_idx]};\n\n            push @len_symbols, $len_idx + 256;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $len - $min);\n            }\n        }\n\n        {\n            my $dist_idx = $DISTANCE_INDICES[$dist];\n            my ($min, $bits) = @{$DISTANCE_SYMBOLS[$dist_idx]};\n\n            push @dist_symbols, $dist_idx;\n\n            if ($bits > 0) {\n                $offset_bits .= sprintf('%0*b', $bits, $dist - $min);\n            }\n        }\n    }\n\n    create_huffman_entry(\\@len_symbols,  $out_fh);\n    create_huffman_entry(\\@dist_symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n}\n\nsub deflate_decode ($fh) {\n\n    my $len_symbols  = decode_huffman_entry($fh);\n    my $dist_symbols = decode_huffman_entry($fh);\n\n    my $bits_len = 0;\n\n    foreach my $i (@$dist_symbols) {\n        $bits_len += $DISTANCE_SYMBOLS[$i][1];\n    }\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            $bits_len += $LENGTH_SYMBOLS[$i - 256][1];\n        }\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @literals;\n    my @lengths;\n    my @distances;\n\n    my $j = 0;\n\n    foreach my $i (@$len_symbols) {\n        if ($i >= 256) {\n            my $dist = $dist_symbols->[$j++];\n            push @literals,  undef;\n            push @lengths,   $LENGTH_SYMBOLS[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS[$i - 256][1], ''));\n            push @distances, $DISTANCE_SYMBOLS[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$dist][1], ''));\n        }\n        else {\n            push @literals,  $i;\n            push @lengths,   0;\n            push @distances, 0;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@$alphabet, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@$alphabet, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        if ($enc == 0) {\n            $populated <<= 1;\n        }\n        else {\n            ($populated <<= 1) |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Populated : \", sprintf('%08b', $populated);\n    say \"Marked    : @marked\";\n    say \"Delta len : \", length($delta);\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh))));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my @bytes        = unpack('C*', $chunk);\n    my @alphabet     = sort { $a <=> $b } uniq(@bytes);\n    my $alphabet_enc = encode_alphabet(\\@alphabet);\n\n    my $mtf  = mtf_encode(\\@bytes, [@alphabet]);\n    my $rle4 = rle4_encode($mtf);\n\n    my (@uncompressed, @indices, @lengths);\n    lz77_compression(pack('C*', @$rle4), \\@uncompressed, \\@indices, \\@lengths);\n\n    my $est_ratio = length($chunk) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices));\n    say scalar(@uncompressed), ' -> ', $est_ratio;\n\n    print $out_fh $alphabet_enc;\n    deflate_encode(\\@uncompressed, \\@indices, \\@lengths, $out_fh);\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $alphabet = decode_alphabet($fh);\n    say \"Alphabet size: \", scalar(@$alphabet);\n\n    my ($uncompressed, $indices, $lengths) = deflate_decode($fh);\n    my @rle4  = unpack('C*', lz77_decompression($uncompressed, $indices, $lengths));\n    my $mtf   = rle4_decode(\\@rle4);\n    my $bytes = mtf_decode($mtf, $alphabet);\n    print $out_fh pack('C*', @$bytes);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/ppmh_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 11 August 2023\n# https://github.com/trizen\n\n# Compress/decompress files using Prediction by partial-matching (PPM) + Huffman coding.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 16 - Adaptive Methods\n#   https://youtube.com/watch?v=YKv-w8bXi9c\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\n\nuse constant {\n    PKGNAME => 'PPMH',\n    VERSION => '0.01',\n    FORMAT  => 'ppmh',\n\n    CHUNK_SIZE      => 1 << 16,\n    ESCAPE_SYMBOL   => 256,       # escape symbol\n    CONTEXTS_NUM    => 4,         # maximum number of contexts\n    INITIAL_CONTEXT => 1,         # start in this context\n    VERBOSE         => 0,         # verbose/debug mode\n\n    PPM_MODE     => chr(0),\n    VLR_MODE     => chr(1),\n    HUFFMAN_MODE => chr(2),\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub encode_alphabet ($alphabet) {\n\n    my %table;\n    @table{@$alphabet} = ();\n\n    my $populated = 0;\n    my @marked;\n\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n\n        my $enc = 0;\n        foreach my $j (0 .. 31) {\n            if (exists($table{$i + $j})) {\n                $enc |= 1 << $j;\n            }\n        }\n\n        $populated <<= 1;\n\n        if ($enc != 0) {\n            $populated |= 1;\n            push @marked, $enc;\n        }\n    }\n\n    my $delta = delta_encode([@marked], 1);\n\n    say \"Uniq symbs : \", scalar(@$alphabet);\n    say \"Max symbol : \", max(@$alphabet);\n    say \"Populated  : \", sprintf('%08b', $populated);\n    say \"Marked     : @marked\";\n    say \"Delta len  : \", length($delta);\n\n    my $encoded = '';\n    $encoded .= chr($populated);\n    $encoded .= $delta;\n    return $encoded;\n}\n\nsub decode_alphabet ($fh) {\n\n    my @populated = split(//, sprintf('%08b', ord(getc($fh))));\n    my $marked    = delta_decode($fh, 1);\n\n    my @alphabet;\n    for (my $i = 0 ; $i <= 255 ; $i += 32) {\n        if (shift(@populated)) {\n            my $m = shift(@$marked);\n            foreach my $j (0 .. 31) {\n                if ($m & 1) {\n                    push @alphabet, $i + $j;\n                }\n                $m >>= 1;\n            }\n        }\n    }\n\n    return \\@alphabet;\n}\n\nsub freq ($arr) {\n    my %freq;\n    ++$freq{$_} for @$arr;\n    return \\%freq;\n}\n\nsub ppm_encode ($symbols, $alphabet) {\n\n    my @enc;\n    my @prev;\n    my $s = join(' ', @prev);\n\n    my @ctx = ({$s => {freq => freq($alphabet)}},);\n\n    foreach my $i (1 .. CONTEXTS_NUM) {\n        push @ctx, {$s => {freq => freq([ESCAPE_SYMBOL])}};\n    }\n\n    foreach my $c (@ctx) {\n        $c->{$s}{tree} = (mktree_from_freq($c->{$s}{freq}))[0];\n    }\n\n    my $prev_ctx = INITIAL_CONTEXT;\n\n    foreach my $symbol (@$symbols) {\n\n        foreach my $k (reverse(0 .. $prev_ctx)) {\n            $s = join(' ', @prev[max($#prev - $k + 2, 0) .. $#prev]);\n\n            if (!exists($ctx[$k]{$s})) {\n                $ctx[$k]{$s}{freq} = freq([ESCAPE_SYMBOL]);\n            }\n\n            if (exists($ctx[$k]{$s}{freq}{$symbol})) {\n\n                if ($k != 0) {\n                    $ctx[$k]{$s}{tree} = (mktree_from_freq($ctx[$k]{$s}{freq}))[0];\n                    ++$ctx[$k]{$s}{freq}{$symbol};\n                }\n\n                say STDERR \"Encoding $symbol with context=$k using $ctx[$k]{$s}{tree}{$symbol} and prefix ($s)\" if VERBOSE;\n                push @enc, $ctx[$k]{$s}{tree}{$symbol};\n                ++$prev_ctx if ($prev_ctx < $#ctx);\n\n                push @prev, $symbol;\n                shift(@prev) if (scalar(@prev) >= CONTEXTS_NUM);\n                last;\n            }\n\n            --$prev_ctx;\n            $ctx[$k]{$s}{tree} = (mktree_from_freq($ctx[$k]{$s}{freq}))[0];\n            push @enc, $ctx[$k]{$s}{tree}{(ESCAPE_SYMBOL)};\n            say STDERR \"Escaping from context = $k with $ctx[$k]{$s}{tree}{(ESCAPE_SYMBOL)}\" if VERBOSE;\n            $ctx[$k]{$s}{freq}{$symbol} = 1;\n        }\n    }\n\n    return join('', @enc);\n}\n\nsub ppm_decode ($enc, $alphabet) {\n\n    my @out;\n    my @prev;\n    my $prefix = '';\n    my $s      = join(' ', @prev);\n\n    my @ctx = ({$s => {freq => freq($alphabet)}},);\n\n    foreach my $i (1 .. CONTEXTS_NUM) {\n        push @ctx, {$s => {freq => freq([ESCAPE_SYMBOL])}},;\n    }\n\n    foreach my $c (@ctx) {\n        $c->{$s}{tree} = (mktree_from_freq($c->{$s}{freq}))[1];\n    }\n\n    my $prev_ctx = my $context = INITIAL_CONTEXT;\n    my @key      = @prev;\n\n    foreach my $bit (split(//, $enc)) {\n\n        $prefix .= $bit;\n\n        if (!exists($ctx[$context]{$s})) {\n            $ctx[$context]{$s}{freq} = freq([ESCAPE_SYMBOL]);\n            $ctx[$context]{$s}{tree} = (mktree_from_freq($ctx[$context]{$s}{freq}))[1];\n        }\n\n        if (exists($ctx[$context]{$s}{tree}{$prefix})) {\n            my $symbol = $ctx[$context]{$s}{tree}{$prefix};\n            if ($symbol == ESCAPE_SYMBOL) {\n                --$context;\n                shift(@key) if (scalar(@key) >= $context);\n                $s = join(' ', @key);\n            }\n            else {\n                push @out, $symbol;\n                foreach my $k (max($context, 1) .. $prev_ctx) {\n                    my $s = join(' ', @prev[max($#prev - $k + 2, 0) .. $#prev]);\n                    $ctx[$k]{$s}{freq} //= freq([ESCAPE_SYMBOL]);\n                    ++$ctx[$k]{$s}{freq}{$symbol};\n                    $ctx[$k]{$s}{tree} = (mktree_from_freq($ctx[$k]{$s}{freq}))[1];\n                }\n                ++$context if ($context < $#ctx);\n                $prev_ctx = $context;\n                push @prev, $symbol;\n                shift(@prev) if (scalar(@prev) >= CONTEXTS_NUM);\n                @key = @prev[max($#prev - $context + 2, 0) .. $#prev];\n                $s   = join(' ', @key);\n            }\n            $prefix = '';\n        }\n    }\n\n    return \\@out;\n}\n\nsub run_length ($arr) {\n\n    @$arr || return [];\n\n    my @result     = [$arr->[0], 1];\n    my $prev_value = $arr->[0];\n\n    foreach my $i (1 .. $#{$arr}) {\n\n        my $curr_value = $arr->[$i];\n\n        if ($curr_value eq $prev_value) {\n            ++$result[-1][1];\n        }\n        else {\n            push(@result, [$curr_value, 1]);\n        }\n\n        $prev_value = $curr_value;\n    }\n\n    return \\@result;\n}\n\nsub binary_vrl_encoding ($str) {\n\n    my @bits      = split(//, $str);\n    my $bitstring = $bits[0];\n\n    foreach my $rle (@{run_length(\\@bits)}) {\n        my ($c, $v) = @$rle;\n\n        if ($v == 1) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', $v - 1);\n            $bitstring .= join('', '1' x length($t), '0', substr($t, 1));\n        }\n    }\n\n    return $bitstring;\n}\n\nsub binary_vrl_decoding ($bitstring) {\n\n    open my $fh, '<:raw', \\$bitstring;\n\n    my $decoded = '';\n    my $bit     = getc($fh) // die \"error\";\n\n    while (!eof($fh)) {\n\n        $decoded .= $bit;\n\n        my $bl = 0;\n        while ((getc($fh) // die \"error\") == 1) {\n            ++$bl;\n        }\n\n        if ($bl > 0) {\n            $decoded .= $bit x oct('0b1' . join('', map { getc($fh) // die \"error\" } 1 .. $bl - 1));\n        }\n\n        $bit = ($bit eq '1' ? '0' : '1');\n    }\n\n    return $decoded;\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n    say \"Max symbol : $max_symbol\\n\";\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    say \"Encoded length: $enc_len\\n\";\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\nsub compression ($chunk, $out_fh) {\n\n    my @bytes        = unpack('C*', $chunk);\n    my @alphabet     = sort { $a <=> $b } uniq(@bytes);\n    my $alphabet_enc = encode_alphabet(\\@alphabet);\n\n    my $enc = ppm_encode(\\@bytes, \\@alphabet);\n    printf(\"Before VRL : %s (saving %.2f%%)\\n\", length($enc), (length($chunk) - length($enc) / 8) / length($chunk) * 100);\n\n    my $vrl_enc = binary_vrl_encoding($enc);\n    printf(\"After VRL  : %s (saving %.2f%%)\\n\\n\", length($vrl_enc), (length($chunk) - length($vrl_enc) / 8) / length($chunk) * 100);\n\n    my $mode = PPM_MODE;\n\n    if (length($vrl_enc) < length($enc)) {\n        $mode = VLR_MODE;\n        $enc  = $vrl_enc;\n    }\n    else {\n        $mode = PPM_MODE;\n    }\n\n    if (length($enc) / 8 > length($chunk)) {\n        $mode = HUFFMAN_MODE;\n    }\n\n    print $out_fh $mode;\n\n    if ($mode eq HUFFMAN_MODE) {\n        create_huffman_entry(\\@bytes, $out_fh);\n    }\n    else {\n        print $out_fh pack('N', length($enc));\n        print $out_fh $alphabet_enc;\n        print $out_fh pack('B*', $enc);\n    }\n}\n\nsub decompression ($fh, $out_fh) {\n\n    my $mode = getc($fh) // die \"decompression error\";\n\n    if ($mode eq HUFFMAN_MODE) {\n        say \"Decoding Huffman entry...\";\n        print $out_fh pack('C*', @{decode_huffman_entry($fh)});\n        return 1;\n    }\n\n    my $enc_len  = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4));\n    my $alphabet = decode_alphabet($fh);\n\n    say \"Length = $enc_len\";\n    say \"Alphabet size: \", scalar(@$alphabet);\n\n    my $bitstring = read_bits($fh, $enc_len);\n\n    if ($mode eq VLR_MODE) {\n        say \"Decoding VRL...\";\n        $bitstring = binary_vrl_decoding($bitstring);\n    }\n\n    say '';\n    print $out_fh pack('C*', @{ppm_decode($bitstring, $alphabet)});\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/qof_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# A general purpose lossless compressor, based on ideas from the QOI compressor.\n\n# See also:\n#   https://qoiformat.org/\n\nuse 5.036;\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\nuse List::Util        qw(max);\nuse Getopt::Std       qw(getopts);\n\nbinmode(STDIN,  \":raw\");\nbinmode(STDOUT, \":raw\");\n\nuse constant {\n              PKGNAME    => 'QOF',\n              FORMAT     => 'qof',\n              VERSION    => '0.01',\n              CHUNK_SIZE => 1 << 14,\n             };\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub usage ($code = 0) {\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub qof_encoder ($string) {\n\n    use constant {\n                  QOI_OP_RGB  => 0b1111_1110,\n                  QOI_OP_DIFF => 0b01_000_000,\n                  QOI_OP_RUN  => 0b11_000_000,\n                  QOI_OP_LUMA => 0b10_000_000,\n                 };\n\n    my $run     = 0;\n    my $px      = 0;\n    my $prev_px = -1;\n\n    my @bytes;\n    my @table = (0) x 64;\n    my @chars = unpack('C*', $string);\n\n    while (@chars) {\n\n        $px = shift(@chars);\n\n        if ($px == $prev_px) {\n            if (++$run == 62) {\n                push @bytes, QOI_OP_RUN | ($run - 1);\n                $run = 0;\n            }\n        }\n        else {\n\n            if ($run > 0) {\n                push @bytes, (QOI_OP_RUN | ($run - 1));\n                $run = 0;\n            }\n\n            my $hash     = $px % 64;\n            my $index_px = $table[$hash];\n\n            if ($px == $index_px) {\n                push @bytes, $hash;\n            }\n            else {\n\n                $table[$hash] = $px;\n                my $diff = $px - $prev_px;\n\n                if ($diff > -33 and $diff < 32) {\n                    push(@bytes, QOI_OP_DIFF | ($diff + 32));\n                }\n                else {\n                    push(@bytes, QOI_OP_RGB, $px);\n                }\n            }\n        }\n\n        $prev_px = $px;\n    }\n\n    if ($run > 0) {\n        push(@bytes, QOI_OP_RUN | ($run - 1));\n    }\n\n    create_huffman_entry(\\@bytes);\n}\n\nsub qof_decoder ($fh) {\n\n    use constant {\n                  QOI_OP_RGB   => 0b1111_1110,\n                  QOI_OP_DIFF  => 0b01_000_000,\n                  QOI_OP_RUN   => 0b11_000_000,\n                  QOI_OP_LUMA  => 0b10_000_000,\n                  QOI_OP_INDEX => 0b00_000_000,\n                 };\n\n    my $run = 0;\n    my $px  = -1;\n\n    my @bytes;\n    my @table = ((0) x 64);\n\n    my $index   = 0;\n    my @symbols = @{decode_huffman_entry($fh)};\n\n    while (1) {\n\n        if ($run > 0) {\n            --$run;\n        }\n        else {\n            my $byte = $symbols[$index++] // last;\n\n            if ($byte == QOI_OP_RGB) {    # OP RGB\n                $px = $symbols[$index++];\n            }\n            elsif (($byte >> 6) == (QOI_OP_INDEX >> 6)) {    # OP INDEX\n                $px = $table[$byte];\n            }\n            elsif (($byte >> 6) == (QOI_OP_DIFF >> 6)) {     # OP DIFF\n                $px += ($byte & 0b00_111_111) - 32;\n            }\n            elsif (($byte >> 6) == (QOI_OP_RUN >> 6)) {      # OP RUN\n                $run = ($byte & 0b00_111_111);\n            }\n\n            $table[$px % 64] = $px;\n        }\n\n        push @bytes, $px;\n    }\n\n    return pack('C*', @bytes);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        print $out_fh qof_encoder($chunk);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        print $out_fh qof_decoder($fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/rans_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# File compression with rANS encoding, using big integers.\n\n# Reference:\n#   ‎Stanford EE274: Data Compression I 2023 I Lecture 7 - ANS\n#   https://youtube.com/watch?v=5Hp4bnvSjng\n\nuse 5.036;\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max);\n\nuse Math::GMPz;\n\nuse constant {\n              PKGNAME => 'rANS',\n              VERSION => '0.01',\n              FORMAT  => 'rans',\n             };\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage ($code = 0) {\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub valid_archive ($fh) {\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub cumulative_freq ($freq) {\n\n    my %cf;\n    my $total = Math::GMPz->new(0);\n    foreach my $c (sort keys %{$freq}) {\n        $cf{$c} = $total;\n        $total += $freq->{$c};\n    }\n\n    return %cf;\n}\n\nsub rans_base_enc($freq, $cumul, $M, $x_prev, $s, $block_id, $x) {\n\n    Math::GMPz::Rmpz_div_ui($block_id, $x_prev, $freq->{$s});\n\n    my $r    = Math::GMPz::Rmpz_mod_ui($x, $x_prev, $freq->{$s});\n    my $slot = $cumul->{$s} + $r;\n\n    Math::GMPz::Rmpz_mul_ui($x, $block_id, $M);\n    Math::GMPz::Rmpz_add_ui($x, $x, $slot);\n\n    return $x;\n}\n\nsub encode($input, $freq, $cumul, $M) {\n\n    my $x        = Math::GMPz::Rmpz_init_set_ui(0);\n    my $block_id = Math::GMPz::Rmpz_init();\n    my $next_x   = Math::GMPz::Rmpz_init();\n\n    foreach my $s (@$input) {\n        $x = rans_base_enc($freq, $cumul, $M, $x, $s, $block_id, $next_x);\n    }\n\n    return $x;\n}\n\nsub rans_base_dec($alphabet, $freq, $cumul, $M, $x, $block_id, $slot, $x_prev) {\n\n    Math::GMPz::Rmpz_tdiv_qr_ui($block_id, $slot, $x, $M);\n\n    my ($left, $right, $mid, $cmp) = (0, $#{$alphabet});\n\n    while (1) {\n\n        $mid = ($left + $right) >> 1;\n        $cmp = ($cumul->{$alphabet->[$mid]} <=> $slot) || last;\n\n        if ($cmp < 0) {\n            $left = $mid + 1;\n            $left > $right and last;\n        }\n        else {\n            $right = $mid - 1;\n\n            if ($left > $right) {\n                $mid -= 1;\n                last;\n            }\n        }\n    }\n\n    my $s = $alphabet->[$mid];\n\n    Math::GMPz::Rmpz_mul_ui($x_prev, $block_id, $freq->{$s});\n    Math::GMPz::Rmpz_add($x_prev, $x_prev, $slot);\n    Math::GMPz::Rmpz_sub_ui($x_prev, $x_prev, $cumul->{$s});\n\n    return ($s, $x_prev);\n}\n\nsub decode($x, $alphabet, $freq, $cumul, $M) {\n\n    my @dec;\n    my $s = undef;\n\n    my $block_id = Math::GMPz::Rmpz_init();\n    my $slot     = Math::GMPz::Rmpz_init();\n    my $x_prev   = Math::GMPz::Rmpz_init();\n\n    for (1 .. $M) {\n        ($s, $x) = rans_base_dec($alphabet, $freq, $cumul, $M, $x, $block_id, $slot, $x_prev);\n        push @dec, $s;\n    }\n\n    return [reverse @dec];\n}\n\nsub compress ($input, $output) {\n\n    # Open the input file\n    open my $fh, '<:raw', $input;\n\n    # Open the output file and write the archive signature\n    open my $out_fh, '>:raw', $output;\n    print {$out_fh} SIGNATURE;\n\n    my $str = do {\n        local $/;\n        scalar(<$fh>);\n    };\n\n    close $fh;\n\n    my (%freq, %cumul);\n    my @symbols = unpack('C*', $str);\n    ++$freq{$_} for @symbols;\n\n    my @alphabet = sort { $a <=> $b } keys %freq;\n\n    my $t = 0;\n    foreach my $s (@alphabet) {\n        $cumul{$s} = $t;\n        $t += $freq{$s};\n    }\n\n    my $M   = $t;\n    my $enc = encode(\\@symbols, \\%freq, \\%cumul, $M);\n\n    my $bin        = Math::GMPz::Rmpz_get_str($enc, 2);\n    my $max_symbol = max(keys %freq) // 0;\n\n    my @freqs;\n    foreach my $k (0 .. $max_symbol) {\n        push @freqs, $freq{$k} // 0;\n    }\n\n    print {$out_fh} delta_encode(\\@freqs);\n    print {$out_fh} pack('N',  length($bin));\n    print {$out_fh} pack('B*', $bin);\n    close $out_fh;\n}\n\nsub decompress ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input;\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E archive!\\n\";\n\n    my @freqs    = @{delta_decode($fh)};\n    my $bits_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n\n    # Create the frequency table\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i] > 0) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    # Decode the bits into an integer\n    my $enc = Math::GMPz->new(read_bits($fh, $bits_len), 2);\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output;\n\n    my @alphabet = sort { $a <=> $b } keys %freq;\n\n    my $t = 0;\n    my %cumul;\n    foreach my $s (@alphabet) {\n        $cumul{$s} = $t;\n        $t += $freq{$s};\n    }\n\n    my $M       = $t;\n    my $symbols = decode($enc, \\@alphabet, \\%freq, \\%cumul, $M);\n    print $out_fh pack('C*', @$symbols);\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/rlac_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 13 August 2023\n# Edit: 06 February 2024\n# https://github.com/trizen\n\n# Compress/decompress files using Run-length encoding + Arithmetic Coding (in fixed bits).\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 15 - Infinite Precision in Finite Bits\n#   https://youtube.com/watch?v=EqKbT3QdtOI\n#\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq sum);\n\nuse constant {\n    PKGNAME => 'RLAC',\n    VERSION => '0.02',\n    FORMAT  => 'rlac',\n\n    CHUNK_SIZE => 1 << 16,\n};\n\n# Arithmetic Coding settings\nuse constant BITS => 32;\nuse constant MAX  => oct('0b' . ('1' x BITS));\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(2);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub create_cfreq ($freq) {\n\n    my @cf;\n    my $T = 0;\n\n    foreach my $i (sort { $a <=> $b } keys %$freq) {\n        $freq->{$i} // next;\n        $cf[$i] = $T;\n        $T += $freq->{$i};\n        $cf[$i + 1] = $T;\n    }\n\n    return (\\@cf, $T);\n}\n\nsub ac_encode ($bytes_arr) {\n\n    my $enc        = '';\n    my $EOF_SYMBOL = (max(@$bytes_arr) // 0) + 1;\n    my @bytes      = (@$bytes_arr, $EOF_SYMBOL);\n\n    my %freq;\n    ++$freq{$_} for @bytes;\n\n    my ($cf, $T) = create_cfreq(\\%freq);\n\n    if ($T > MAX) {\n        die \"Too few bits: $T > ${\\MAX}\";\n    }\n\n    my $low      = 0;\n    my $high     = MAX;\n    my $uf_count = 0;\n\n    foreach my $c (@bytes) {\n\n        my $w = $high - $low + 1;\n\n        $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$c]) / $T)) & MAX;\n\n        if ($high > MAX) {\n            die \"high > MAX: $high > ${\\MAX}\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n\n                my $bit = $high >> (BITS - 1);\n                $enc .= $bit;\n\n                if ($uf_count > 0) {\n                    $enc .= join('', 1 - $bit) x $uf_count;\n                    $uf_count = 0;\n                }\n\n                $low <<= 1;\n                ($high <<= 1) |= 1;\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                ++$uf_count;\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n        }\n    }\n\n    $enc .= '0';\n    $enc .= '1';\n\n    while (length($enc) % 8 != 0) {\n        $enc .= '1';\n    }\n\n    return ($enc, \\%freq);\n}\n\nsub ac_decode ($fh, $freq) {\n\n    my ($cf, $T) = create_cfreq($freq);\n\n    my @dec;\n    my $low  = 0;\n    my $high = MAX;\n    my $enc  = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS);\n\n    my @table;\n    foreach my $i (sort { $a <=> $b } keys %$freq) {\n        foreach my $j ($cf->[$i] .. $cf->[$i + 1] - 1) {\n            $table[$j] = $i;\n        }\n    }\n\n    my $EOF_SYMBOL = max(keys %$freq) // 0;\n\n    while (1) {\n\n        my $w  = $high - $low + 1;\n        my $ss = int((($T * ($enc - $low + 1)) - 1) / $w);\n\n        my $i = $table[$ss] // last;\n        last if ($i == $EOF_SYMBOL);\n\n        push @dec, $i;\n\n        $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$i]) / $T)) & MAX;\n\n        if ($high > MAX) {\n            die \"error\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n                ($high <<= 1) |= 1;\n                $low <<= 1;\n                ($enc <<= 1) |= (getc($fh) // 1);\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1);\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n            $enc  &= MAX;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub create_ac_entry ($bytes, $out_fh) {\n\n    my ($enc, $freq) = ac_encode($bytes);\n    my $max_symbol = max(keys %$freq) // 0;\n\n    say \"Max symbol: $max_symbol\";\n\n    my @freqs;\n    foreach my $k (0 .. $max_symbol) {\n        push @freqs, $freq->{$k} // 0;\n    }\n\n    push @freqs, length($enc) >> 3;\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_ac_entry ($fh) {\n\n    my @freqs    = @{delta_decode($fh)};\n    my $bits_len = pop(@freqs);\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    say \"Encoded length: $bits_len\";\n    my $bits = read_bits($fh, $bits_len << 3);\n\n    if ($bits_len > 0) {\n        open my $bits_fh, '<:raw', \\$bits;\n        return ac_decode($bits_fh, \\%freq);\n    }\n\n    return [];\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub compression ($chunk, $out_fh) {\n    my $bytes = [unpack('C*', $chunk)];\n    $bytes = rle4_encode($bytes);\n    create_ac_entry($bytes, $out_fh);\n}\n\nsub decompression ($fh, $out_fh) {\n    my $bytes = decode_ac_entry($fh);\n    $bytes = rle4_decode($bytes);\n    print $out_fh pack('C*', @$bytes);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/rlh_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 13 August 2023\n# https://github.com/trizen\n\n# Compress/decompress files using Run-length encoding + Huffman coding.\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(max uniq);\n\nuse constant {\n    PKGNAME => 'RLH',\n    VERSION => '0.01',\n    FORMAT  => 'rlh',\n\n    CHUNK_SIZE => 1 << 15,\n};\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh, $double = 0) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)];    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my @symbols = sort { $a <=> $b } keys(%freq);\n\n    print $out_fh delta_encode([@symbols]);\n    print $out_fh delta_encode([map { $freq{$_} } @symbols], 1);\n\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my $symbols = delta_decode($fh);\n    my $freqs   = delta_decode($fh, 1);\n\n    my %freq;\n    foreach my $i (0 .. $#{$symbols}) {\n        $freq{$symbols->[$i]} = $freqs->[$i];\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    my $enc_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n    say \"Encoded length: $enc_len\";\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return [];\n}\n\nsub rle4_encode ($bytes) {    # RLE1\n\n    my @rle;\n    my $end  = $#{$bytes};\n    my $prev = -1;\n    my $run  = 0;\n\n    for (my $i = 0 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @rle, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n\n            $run = 0;\n            $i += 1;\n\n            while ($i <= $end and $bytes->[$i] == $prev) {\n                ++$run;\n                ++$i;\n            }\n\n            push @rle, $run;\n            $run = 1;\n\n            if ($i <= $end) {\n                $prev = $bytes->[$i];\n                push @rle, $bytes->[$i];\n            }\n        }\n    }\n\n    return \\@rle;\n}\n\nsub rle4_decode ($bytes) {    # RLE1\n\n    my @dec  = $bytes->[0];\n    my $end  = $#{$bytes};\n    my $prev = $bytes->[0];\n    my $run  = 1;\n\n    for (my $i = 1 ; $i <= $end ; ++$i) {\n\n        if ($bytes->[$i] == $prev) {\n            ++$run;\n        }\n        else {\n            $run = 1;\n        }\n\n        push @dec, $bytes->[$i];\n        $prev = $bytes->[$i];\n\n        if ($run >= 4) {\n            if (++$i <= $end) {\n                $run = $bytes->[$i];\n                push @dec, (($prev) x $run);\n            }\n\n            $run = 0;\n        }\n    }\n\n    return \\@dec;\n}\n\nsub compression ($chunk, $out_fh) {\n    my $bytes = [unpack('C*', $chunk)];\n    $bytes = rle4_encode($bytes);\n    create_huffman_entry($bytes, $out_fh);\n}\n\nsub decompression ($fh, $out_fh) {\n    my $bytes = decode_huffman_entry($fh);\n    $bytes = rle4_decode($bytes);\n    print $out_fh pack('C*', @$bytes);\n}\n\n# Compress file\nsub compress_file ($input, $output) {\n\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    my $header = SIGNATURE;\n\n    # Open the output file for writing\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for write: $!\";\n\n    # Print the header\n    print $out_fh $header;\n\n    # Compress data\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        compression($chunk, $out_fh);\n    }\n\n    # Close the file\n    close $out_fh;\n}\n\n# Decompress file\nsub decompress_file ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input\n      or die \"Can't open file <<$input>> for reading: $!\";\n\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E v${\\VERSION} archive!\\n\";\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output\n      or die \"Can't open file <<$output>> for writing: $!\";\n\n    while (!eof($fh)) {\n        decompression($fh, $out_fh);\n    }\n\n    # Close the file\n    close $fh;\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/tac_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 01 May 2015\n# Website: https://github.com/trizen\n\n#\n## The arithmetic coding algorithm.\n#\n\n# See: https://en.wikipedia.org/wiki/Arithmetic_coding#Arithmetic_coding_as_a_generalized_change_of_radix\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse Math::BigInt (try => 'GMP');\n\nuse constant {\n              PKGNAME => 'TAC Compressor',\n              VERSION => '0.02',\n              FORMAT  => 'tac',\n             };\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(1);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub cumulative_freq {\n    my ($freq) = @_;\n\n    my %cf;\n    my $total = Math::BigInt->new(0);\n    foreach my $c (sort keys %{$freq}) {\n        $cf{$c} = $total;\n        $total += $freq->{$c};\n    }\n\n    return %cf;\n}\n\nsub compress {\n    my ($input, $output) = @_;\n\n    use bytes;\n\n    # Open the input file\n    open my $fh, '<:raw', $input;\n\n    # Open the output file and write the archive signature\n    open my $out_fh, '>:raw', $output;\n    print {$out_fh} SIGNATURE;\n\n    my $str = do {\n        local $/;\n        scalar(<$fh>);\n    };\n\n    close $fh;\n\n    my @chars = split(//, $str);\n\n    # The frequency characters\n    my %freq;\n    $freq{$_}++ for @chars;\n\n    # Create the cumulative frequency table\n    my %cf = cumulative_freq(\\%freq);\n\n    # Limit and base\n    my $base = Math::BigInt->new(scalar @chars);\n\n    # Lower bound\n    my $L = Math::BigInt->new(0);\n\n    # Product of all frequencies\n    my $pf = Math::BigInt->new(1);\n\n    # Each term is multiplied by the product of the\n    # frequencies of all previously occurring symbols\n    foreach my $c (@chars) {\n        $L->bmuladd($base, $cf{$c} * $pf);\n        $pf->bmul($freq{$c});\n    }\n\n    # Upper bound\n    my $U = $L + $pf;\n\n    my $pow = $pf->copy->blog(2);\n    my $enc = ($U - 1)->bdiv(Math::BigInt->new(2)->bpow($pow));\n\n    # Remove any divisibility by 2\n    while ($enc > 0 and $enc % 2 == 0) {\n        $pow->binc;\n        $enc->brsft(1);\n    }\n\n    my $bin     = substr($enc->as_bin, 2);\n    my $encoded = pack('L', $pow);              # the power value\n    $encoded .= chr(scalar(keys %freq) - 1);    # number of unique chars\n    $encoded .= chr(length($bin) % 8);          # padding\n\n    while (my ($k, $v) = each %freq) {\n        $encoded .= $k . pack('S', $v);         # char => freq\n    }\n\n    print {$out_fh} $encoded, pack('B*', $bin);\n    close $out_fh;\n}\n\nsub decompress {\n    my ($input, $output) = @_;\n\n    use bytes;\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input;\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E archive!\\n\";\n    my $content = do { local $/; <$fh> };\n    close $fh;\n\n    my ($pow, $uniq, $padd) = unpack('LCC', $content);\n    substr($content, 0, length(pack('LCC', 0, 0, 0)), '');\n\n    # Create the frequency table (char => freq)\n    my %freq;\n    foreach my $i (0 .. $uniq) {\n        my ($char, $f) = unpack('aS', $content);\n        $freq{$char} = $f;\n        substr($content, 0, length(pack('aS', 0, 0)), '');\n    }\n\n    # Decode the bits into an integer\n    my $enc = Math::BigInt->new('0b' . unpack('B*', $content));\n\n    # Remove the trailing bits (if any)\n    if ($padd != 0) {\n        $enc >>= (8 - $padd);\n    }\n\n    $pow = Math::BigInt->new($pow);\n    $enc->blsft($pow);\n\n    my $base = Math::BigInt->new(0);\n    $base += $_ for values %freq;\n\n    # Create the cumulative frequency table\n    my %cf = cumulative_freq(\\%freq);\n\n    # Create the dictionary\n    my %dict;\n    while (my ($k, $v) = each %cf) {\n        $dict{$v} = $k;\n    }\n\n    # Fill the gaps in the dictionary\n    my $lchar;\n    foreach my $i (0 .. $base - 1) {\n        if (exists $dict{$i}) {\n            $lchar = $dict{$i};\n        }\n        elsif (defined $lchar) {\n            $dict{$i} = $lchar;\n        }\n    }\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output;\n\n    # Decode the input number\n    for (my $pow = $base**($base - 1) ; $pow > 0 ; $pow /= $base) {\n        my $div = $enc / $pow;\n\n        my $c  = $dict{$div};\n        my $fv = $freq{$c};\n        my $cv = $cf{$c};\n\n        $enc = ($enc - $pow * $cv) / $fv;\n        print {$out_fh} $c;\n    }\n\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/tacc_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 11 February 2016\n# Edit: 14 July 2023\n# https://github.com/trizen\n\n# Arithmetic coding compressor for small files.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Arithmetic_coding#Arithmetic_coding_as_a_generalized_change_of_radix\n\nuse 5.020;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\nuse List::Util     qw(sum max);\nuse experimental   qw(signatures);\n\nuse Math::GMPz;\n\nuse constant {\n              PKGNAME => 'TAC Compressor',\n              VERSION => '0.05',\n              FORMAT  => 'tacc',\n             };\n\n# Container signature\nuse constant SIGNATURE => uc(FORMAT) . chr(5);\n\nsub usage ($code = 0) {\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code);\n}\n\nsub version {\n    printf(\"%s %s\\n\", PKGNAME, VERSION);\n    exit;\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub valid_archive ($fh) {\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub cumulative_freq ($freq) {\n\n    my %cf;\n    my $total = Math::GMPz->new(0);\n    foreach my $c (sort keys %{$freq}) {\n        $cf{$c} = $total;\n        $total += $freq->{$c};\n    }\n\n    return %cf;\n}\n\nsub compress ($input, $output) {\n\n    # Open the input file\n    open my $fh, '<:raw', $input;\n\n    # Open the output file and write the archive signature\n    open my $out_fh, '>:raw', $output;\n    print {$out_fh} SIGNATURE;\n\n    my $str = do {\n        local $/;\n        scalar(<$fh>);\n    };\n\n    close $fh;\n\n    my @chars = split(//, $str);\n\n    # The frequency characters\n    my %freq;\n    $freq{$_}++ for @chars;\n\n    # Create the cumulative frequency table\n    my %cf = cumulative_freq(\\%freq);\n\n    # Limit and base\n    my $base = Math::GMPz->new(scalar @chars);\n\n    # Lower bound\n    my $L = Math::GMPz->new(0);\n\n    # Product of all frequencies\n    my $pf = Math::GMPz->new(1);\n\n    # Each term is multiplied by the product of the\n    # frequencies of all previously occurring symbols\n    foreach my $c (@chars) {\n        Math::GMPz::Rmpz_mul($L, $L, $base);\n        Math::GMPz::Rmpz_addmul($L, $pf, $cf{$c});\n        Math::GMPz::Rmpz_mul_ui($pf, $pf, $freq{$c});\n    }\n\n    # Upper bound\n    my $U = $L + $pf;\n\n    # Compute the power for left shift\n    my $pow = Math::GMPz::Rmpz_sizeinbase($pf, 2) - 1;\n\n    # Set $enc to (U-1) divided by 2^pow\n    my $enc = ($U - 1) >> $pow;\n\n    # Remove any divisibility by 2\n    if ($enc > 0 and Math::GMPz::Rmpz_even_p($enc)) {\n        $pow += Math::GMPz::Rmpz_remove($enc, $enc, Math::GMPz->new(2));\n    }\n\n    my $bin        = Math::GMPz::Rmpz_get_str($enc, 2);\n    my $max_symbol = max(map { ord($_) } keys %freq) // 0;\n\n    my @freqs;\n    foreach my $k (0 .. $max_symbol) {\n        push @freqs, $freq{chr($k)} // 0;\n    }\n\n    push @freqs, $pow;\n\n    print {$out_fh} delta_encode(\\@freqs);\n    print {$out_fh} pack('N',  length($bin));\n    print {$out_fh} pack('B*', $bin);\n    close $out_fh;\n}\n\nsub decompress ($input, $output) {\n\n    # Open and validate the input file\n    open my $fh, '<:raw', $input;\n    valid_archive($fh) || die \"$0: file `$input' is not a \\U${\\FORMAT}\\E archive!\\n\";\n\n    my @freqs = @{delta_decode($fh)};\n    my $pow2  = pop(@freqs);\n\n    my $bits_len = unpack('N', join('', map { getc($fh) // die \"error\" } 1 .. 4));\n\n    # Create the frequency table\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i] > 0) {\n            $freq{chr($i)} = $freqs[$i];\n        }\n    }\n\n    # Decode the bits into an integer\n    my $enc = Math::GMPz->new(read_bits($fh, $bits_len), 2);\n\n    $enc <<= $pow2;\n\n    my $base = sum(values %freq) // 0;\n\n    # Create the cumulative frequency table\n    my %cf = cumulative_freq(\\%freq);\n\n    # Create the dictionary\n    my %dict;\n    while (my ($k, $v) = each %cf) {\n        $dict{$v} = $k;\n    }\n\n    # Fill the gaps in the dictionary\n    my $lchar;\n    foreach my $i (0 .. $base - 1) {\n        if (exists $dict{$i}) {\n            $lchar = $dict{$i};\n        }\n        elsif (defined $lchar) {\n            $dict{$i} = $lchar;\n        }\n    }\n\n    # Open the output file\n    open my $out_fh, '>:raw', $output;\n\n    if ($base == 0) {\n        close $out_fh;\n        return;\n    }\n    elsif ($base == 1) {\n        print {$out_fh} keys %freq;\n        close $out_fh;\n        return;\n    }\n\n    my $div = Math::GMPz::Rmpz_init();\n\n    # Decode the input number\n    for (my $pow = Math::GMPz->new($base)**($base - 1) ; Math::GMPz::Rmpz_sgn($pow) > 0 ; Math::GMPz::Rmpz_tdiv_q_ui($pow, $pow, $base)) {\n\n        Math::GMPz::Rmpz_tdiv_q($div, $enc, $pow);\n\n        my $c  = $dict{$div};\n        my $fv = $freq{$c};\n        my $cv = $cf{$c};\n\n        Math::GMPz::Rmpz_submul($enc, $pow, $cv);\n        Math::GMPz::Rmpz_tdiv_q_ui($enc, $enc, $fv);\n\n        print {$out_fh} $c;\n    }\n\n    close $out_fh;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/test_compressors.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 19 March 2024\n# https://github.com/trizen\n\nuse 5.036;\nuse File::Temp            qw(tempdir tempfile);\nuse File::Compare         qw(compare);\nuse File::Basename        qw(basename);\nuse File::Spec::Functions qw(catfile);\nuse List::Util            qw(min);\nuse Time::HiRes           qw(gettimeofday tv_interval);\n\nmy %ignored_methods = (\n    'tac_file_compression.pl'   => 1,    # slow\n    'tacc_file_compression.pl'  => 1,    # slow\n    'rans_file_compression.pl'  => 1,    # slow\n    'tzip_file_compression.pl'  => 1,    # poor compression / slow\n    'tzip2_file_compression.pl' => 1,    # poor compression / slow\n    'lzt_file_compression.pl'   => 1,    # poor compression\n    'lzhc_file_compression.pl'  => 1,    # very poor compression\n    'lzt2_file_compression.pl'  => 1,    # slow\n    'bbwr_file_compression.pl'  => 1,    # slow\n    'ppmh_file_compression.pl'  => 1,    # slow\n                      );\n\nmy $input_file = shift(@ARGV) // die \"usage: perl $0 [input file] [regex]\\n\";\nmy $regex      = shift(@ARGV) // '';\n\nif (not -f $input_file) {\n    die \"Error for input file <<$input_file>>: $!\\n\";\n}\n\nmy $compressed_dir   = tempdir(CLEANUP => 1);\nmy $decompressed_dir = tempdir(CLEANUP => 1);\n\nmy @stats = ({format => 'orig', filename => basename($input_file), compression_time => 0, decompression_time => 0, size => -s $input_file});\n\nsub commify ($n) {\n    scalar reverse(reverse($n) =~ s/(\\d{3})(?=\\d)/$1,/gr);\n}\n\nforeach my $file (glob(\"*_file_compression.pl\")) {\n\n    next if $ignored_methods{$file};\n    $file =~ /$regex/o or next;\n\n    say \"\\n:: Testing: $file\";\n    my ($format) = $file =~ /^([^_]+)/;\n\n    my $basename        = basename($input_file) . '.' . $format;\n    my $compressed_file = catfile($compressed_dir, $basename);\n    my $compression_t0  = [gettimeofday];\n    system($^X, $file, '-i', $input_file, '-o', $compressed_file);\n    my $compression_dt = tv_interval($compression_t0);\n    $? == 0 or die \"compression error for: $file\";\n\n    my (undef, $decompressed_file) = tempfile(DIR => $decompressed_dir);\n    my $decompression_t0 = [gettimeofday];\n    system($^X, $file, '-r', '-e', '-i', $compressed_file, '-o', $decompressed_file);\n    my $decompression_dt = tv_interval($decompression_t0);\n    $? == 0 or die \"decompression error for: $file\";\n\n    if (compare($decompressed_file, $input_file) != 0) {\n        die \"Decompressed file does not match the input file for: $file\";\n    }\n\n    push @stats,\n      {\n        format             => $format,\n        filename           => $basename,\n        compression_time   => $compression_dt,\n        decompression_time => $decompression_dt,\n        size               => -s $compressed_file,\n      };\n}\n\nsay '';\nprintf(\"%8s %6s %6s %6s %s\\n\", \"SIZE\", \"RATIO\", \"COMPRE\", \"DECOMP\", \"FILENAME\");\nforeach my $entry (sort { $a->{size} <=> $b->{size} } @stats) {\n    printf(\"%8s %6.3f %6.3f %6.3f %s\\n\",\n           commify($entry->{size}),\n           (-s $input_file) / $entry->{size},\n           $entry->{compression_time},\n           $entry->{decompression_time},\n           $entry->{filename});\n}\n\nsay '';\nmy $top = min(20, scalar(@stats) - 1);\n\nsay \"Top $top fastest compression methods: \",\n  join(', ', map { $_->{format} } (sort { $a->{compression_time} <=> $b->{compression_time} } grep { $_->{compression_time} > 0 } @stats)[0 .. $top - 1]);\nsay \"Top $top fastest decompression methods: \",\n  join(', ', map { $_->{format} } (sort { $a->{decompression_time} <=> $b->{decompression_time} } grep { $_->{decompression_time} > 0 } @stats)[0 .. $top - 1]);\n\nsay '';\nsay \"Top $top slowest compression methods: \",\n  join(', ', map { $_->{format} } (sort { $b->{compression_time} <=> $a->{compression_time} } grep { $_->{compression_time} > 0 } @stats)[0 .. $top - 1]);\nsay \"Top $top slowest decompression methods: \",\n  join(', ', map { $_->{format} } (sort { $b->{decompression_time} <=> $a->{decompression_time} } grep { $_->{decompression_time} > 0 } @stats)[0 .. $top - 1]);\n\n__END__\n\n    SIZE  RATIO COMPRE DECOMP FILENAME\n   2,356  6.088  0.148  0.144 perl.bwad\n   2,359  6.081  0.187  0.192 perl.bwlzad2\n   2,379  6.029  0.210  0.193 perl.bwlzad\n   2,413  5.944  0.053  0.037 perl.bwac\n   2,414  5.942  0.056  0.051 perl.bwaz\n   2,418  5.932  0.083  0.067 perl.bwlza2\n   2,426  5.913  0.090  0.065 perl.bwlza\n   2,426  5.913  0.076  0.050 perl.bwt\n   2,443  5.871  0.079  0.061 perl.bwlz\n   2,591  5.536  0.136  0.043 perl.bwrm\n   2,626  5.462  0.134  0.046 perl.bwrl2\n   2,653  5.407  0.153  0.073 perl.bwrlz\n   2,695  5.322  0.179  0.180 perl.lzsad\n   2,751  5.214  0.141  0.052 perl.bwrla\n   2,760  5.197  0.135  0.049 perl.bwrl\n   2,819  5.088  0.079  0.069 perl.lzsa\n   2,831  5.067  0.077  0.041 perl.bwt2\n   2,835  5.060  0.104  0.065 perl.bwlz2\n   2,836  5.058  0.057  0.042 perl.lzss\n   2,865  5.007  0.086  0.048 perl.lzsbw\n   2,868  5.001  0.043  0.041 perl.lzaz\n   2,870  4.998  0.042  0.035 perl.lzac\n   2,877  4.986  0.070  0.059 perl.bwlzss\n   2,878  4.984  0.037  0.030 perl.lzhd\n   2,905  4.938  0.169  0.077 perl.bwrlz2\n   2,980  4.813  0.057  0.028 perl.bww\n   3,003  4.777  0.051  0.042 perl.mra\n   3,005  4.773  0.055  0.046 perl.bwlzhd\n   3,014  4.759  0.135  0.126 perl.lzbwad\n   3,025  4.742  0.065  0.046 perl.mrh\n   3,027  4.739  0.028  0.023 perl.lzw\n   3,028  4.737  0.075  0.040 perl.lzbwd\n   3,030  4.734  0.069  0.050 perl.mrlz\n   3,072  4.669  0.063  0.037 perl.lzbwh\n   3,146  4.559  0.075  0.042 perl.mbwr\n   3,176  4.516  0.062  0.040 perl.lzbwa\n   3,186  4.502  0.057  0.036 perl.lzbw\n   3,214  4.463  0.036  0.031 perl.lzih\n   3,230  4.441  0.022  0.029 perl.rlh\n   3,321  4.319  0.053  0.042 perl.lza\n   3,335  4.301  0.047  0.035 perl.lzh\n   3,504  4.094  0.032  0.037 perl.rlac\n   4,052  3.540  0.030  0.034 perl.hfm\n   4,193  3.421  0.038  0.020 perl.lz77\n  14,344  1.000  0.000  0.000 perl\n\nTop 20 fastest compression methods: rlh, lzw, hfm, rlac, lzih, lzhd, lz77, lzac, lzaz, lzh, mra, lza, bwac, bwlzhd, bwaz, lzss, lzbw, bww, lzbwa, lzbwh\nTop 20 fastest decompression methods: lz77, lzw, bww, rlh, lzhd, lzih, hfm, lzh, lzac, lzbw, lzbwh, bwac, rlac, lzbwa, lzbwd, bwt2, lzaz, lza, mbwr, mra\n\nTop 20 slowest compression methods: bwlzad, bwlzad2, lzsad, bwrlz2, bwrlz, bwad, bwrla, bwrm, bwrl, lzbwad, bwrl2, bwlz2, bwlza, lzsbw, bwlza2, lzsa, bwlz, bwt2, bwt, mbwr\nTop 20 slowest decompression methods: bwlzad, bwlzad2, lzsad, bwad, lzbwad, bwrlz2, bwrlz, lzsa, bwlza2, bwlza, bwlz2, bwlz, bwlzss, bwrla, bwaz, bwt, mrlz, bwrl, lzsbw, bwrl2\n"
  },
  {
    "path": "Compression/tzip2_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 12 August 2013\n# Website: https://trizenx.blogspot.com\n\n#\n## A very simple file compressor.\n#\n\n# Best usage of this script is to compress files which\n# contains not so many different bytes (for example, DNA-sequences)\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse List::Util     qw(min);\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\n\nour $DEBUG = 0;\n\nuse constant {\n              CHUNK_SIZE => 1024,              # in bytes\n              SIGNATURE  => 'TZP2' . chr(1),\n              FORMAT     => 'tzp2',\n             };\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub _make_map {\n    my ($int) = @_;\n\n    my @groups = ([], [], []);\n    for my $i (1 .. 3) {\n        foreach my $j (0 .. length($int) - $i) {\n            $i > 1 && substr($int, $j, 1) == 0 && next;\n            (my $num = substr($int, $j, $i)) > 255 && next;\n            $groups[$i - 1][$j] = $num;\n        }\n    }\n\n    my @map = [[]];\n    for (my $j = 0 ; $j <= $#{$groups[0]} ; $j++) {\n        for (my $i = $j ; $i <= $#{$groups[0]} ; $i++) {\n            if (defined($groups[2][$i])) {\n                push @{$map[$j][$j]}, $groups[2][$i];\n                $i += 2;\n            }\n            elsif (defined($groups[1][$i])) {\n                push @{$map[$j][$j]}, $groups[1][$i];\n                $i += 1;\n            }\n            else {\n                push @{$map[$j][$j]}, $groups[0][$i];\n            }\n        }\n    }\n\n    return \\@map;\n}\n\nsub int2bytes {\n    my ($int) = @_;\n\n    my $data = _make_map($int);\n\n    my @nums;\n    foreach my $arr (@{$data}) {\n        for my $i (0 .. $#{$arr}) {\n            if (ref($arr->[$i]) eq 'ARRAY') {\n                my $head = _make_map(substr($int, 0, $i));\n                push @nums, [@{$head->[0][0]}, @{$arr->[$i]}];\n            }\n        }\n    }\n\n    my $min   = min(map { $#{$_} } @nums);\n    my @bytes = do {\n        my %seen;\n        grep { !$seen{join(' ', @{$_})}++ } grep { $#{$_} == $min } @nums;\n    };\n\n    return \\@bytes;\n}\n\nsub next_power_of_two {\n    my ($number) = @_;\n\n    return 2 if $number <= 1;\n\n    ## If the number is a power of\n    ## two, then return it as it is.\n    unless ($number & ($number - 1)) {\n        return $number;\n    }\n\n    ## Return the next power of two\n    return 2 << (log($number) / log(2));\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub open_file {\n    my ($mode, $file) = @_;\n    open(my $fh, $mode, $file);\n    return $fh;\n}\n\nsub uniq_bytes {\n    my ($fh) = @_;\n\n    my %table;\n    while (my $size = read($fh, (my $chunk), CHUNK_SIZE)) {\n        @table{split //, $chunk} = ();\n    }\n\n    seek($fh, 0, 0);\n    return [keys %table];\n}\n\nsub info {\n    my (%info) = @_;\n\n    print STDERR <<\"EOT\";\ninput       : $info{input}\noutput      : $info{output}\nfilesize    : $info{filesize}\nbits num    : $info{bits_num}\nbytes num   : $info{bytes_num}\ncompressing : $info{compress}\nEOT\n}\n\nsub compress_file {\n    my ($input, $output) = @_;\n\n    my $fh     = open_file('<:raw', $input);\n    my $out_fh = open_file('>:raw', $output);\n\n    my $filesize = -s $input;\n\n    my $uniq_bytes = uniq_bytes($fh);\n    my $bytes_num  = scalar @{$uniq_bytes};\n    my $bits_num   = log(next_power_of_two($bytes_num)) / log(2);\n\n    $DEBUG\n      && info(\n              bytes_num => $bytes_num,\n              bits_num  => $bits_num,\n              input     => $input,\n              output    => $output,\n              filesize  => $filesize,\n              compress  => 'true',\n             );\n\n    my %table;\n    my $bits_map = '';\n\n    foreach my $i (0 .. $#{$uniq_bytes}) {\n        $bits_map .= ($table{$uniq_bytes->[$i]} = sprintf(\"%0${bits_num}b\", $i));\n    }\n\n    my $size_bytes = ${int2bytes($filesize)}[0];\n\n    print {$out_fh} SIGNATURE,\n      chr($#{$size_bytes} + 1),\n      join('', map { chr } @{$size_bytes}),\n      chr($bits_num), chr($bytes_num - 1),\n      join('', @{$uniq_bytes}), pack('B*', $bits_map);\n\n    while (my $size = read($fh, (my $chunk), CHUNK_SIZE)) {\n        print {$out_fh} scalar pack \"B*\", join('', @table{split //, $chunk});\n    }\n\n    return 1;\n}\n\nsub decompress_file {\n    my ($input, $output) = @_;\n\n    my $fh     = open_file('<:raw', $input);\n    my $out_fh = open_file('>:raw', $output);\n\n    valid_archive($fh) || die \"$0: file `$input' is not a TZP archive!\\n\";\n\n    my $fsize_len = do { read($fh, (my $byte), 1); ord $byte };\n    my $filesize  = do {\n        read($fh, (my $bytes), $fsize_len);\n        join('', unpack('C*', $bytes));\n    };\n\n    my $bits_num  = do { read($fh, (my $byte), 1); ord $byte };\n    my $bytes_num = do { read($fh, (my $byte), 1); 1 + ord $byte };\n\n    $DEBUG\n      && info(\n              bytes_num => $bytes_num,\n              bits_num  => $bits_num,\n              input     => $input,\n              output    => $output,\n              filesize  => $filesize,\n              compress  => 'false',\n             );\n\n    my $bytes = do { read($fh, (my $bytes), $bytes_num); [split(//, $bytes)] };\n\n    my $bits_len = $bits_num * $bytes_num;\n    if ((my $mod = $bits_len % 8) != 0) {\n        $bits_len += 8 - $mod;\n    }\n\n    my $bits = do { read($fh, my ($bytes), $bits_len / 8); unpack 'B*', $bytes };\n\n    my %table;\n    foreach my $byte (@{$bytes}) {\n        $table{substr($bits, 0, $bits_num, '')} = $byte;\n    }\n\n    my $byte_counter = 0;\n    my $prev_bits    = '';\n    while (my $size = read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        my $bits     = $prev_bits . unpack('B*', $chunk);\n        my $bits_len = 8 * $size + length($prev_bits);\n\n        my $left = $bits_len % $bits_num;\n\n        $prev_bits =\n          $left == 0\n          ? q{}\n          : substr($bits, $bits_len - $left, $bits_len, '');\n\n        if (($byte_counter += int($bits_len / $bits_num)) > $filesize) {\n            $bits_len -= ($byte_counter - $filesize);\n        }\n\n        print {$out_fh} join('', @{table}{unpack(\"(a$bits_num)\" . int($bits_len / $bits_num), $bits)});\n    }\n\n    return 1;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/tzip_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Șuteu \"Trizen\" Daniel\n# License: GPLv3\n# Date: 12 August 2013\n# Website: https://trizenx.blogspot.com\n\n#\n## A very simple file compressor.\n#\n\n# Best usage of this script is to compress files which\n# contains not so many different bytes (for example, DNA-sequences)\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\n\nour $DEBUG = 0;\n\nuse constant {\n              CHUNK_SIZE => 2 * 1024**2,      # 2 MB\n              SIGNATURE  => 'TZP' . chr(1),\n              FORMAT     => 'tzp',\n             };\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n\n        -v            : version number\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        decompress_file($input, $output)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n        compress_file($input, $output)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nsub next_power_of_two {\n    my ($number) = @_;\n\n    ## If the number is a power of\n    ## two, then return it as it is.\n    unless ($number & ($number - 1)) {\n        return $number;\n    }\n\n    ## Return the next power of two\n    return 2 << (log($number) / log(2));\n}\n\nsub valid_archive {\n    my ($fh) = @_;\n\n    if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) {\n        $sig eq SIGNATURE || return;\n    }\n\n    return 1;\n}\n\nsub open_file {\n    my ($mode, $file) = @_;\n    open(my $fh, $mode, $file);\n    return $fh;\n}\n\nsub uniq_bytes {\n    my ($fh) = @_;\n\n    my %table;\n    while (my $size = read($fh, (my $chunk), CHUNK_SIZE)) {\n        @table{split //, $chunk} = ();\n    }\n\n    seek($fh, 0, 0);\n    return [keys %table];\n}\n\nsub info {\n    my (%info) = @_;\n\n    print STDERR <<\"EOT\";\ninput       : $info{input}\noutput      : $info{output}\nfilesize    : $info{filesize}\nbits num    : $info{bits_num}\nbytes num   : $info{bytes_num}\ncompressing : $info{compress}\nEOT\n}\n\nsub compress_file {\n    my ($input, $output) = @_;\n\n    my $fh     = open_file('<:raw', $input);\n    my $out_fh = open_file('>:raw', $output);\n\n    my $filesize = -s $input;\n\n    my $uniq_bytes = uniq_bytes($fh);\n    my $bytes_num  = scalar @{$uniq_bytes};\n    my $bits_num   = log(next_power_of_two($bytes_num)) / log(2);\n\n    $DEBUG\n      && info(\n              bytes_num => $bytes_num,\n              bits_num  => $bits_num,\n              input     => $input,\n              output    => $output,\n              filesize  => $filesize,\n              compress  => 'true',\n             );\n\n    my %table;\n    my $bits_map = '';\n\n    foreach my $i (0 .. $#{$uniq_bytes}) {\n        $bits_map .= ($table{$uniq_bytes->[$i]} = sprintf(\"%0${bits_num}b\", $i));\n    }\n\n    print {$out_fh} SIGNATURE,\n      chr(int(length($filesize) / 2 + 0.5)),\n      join('', map { chr } unpack '(A2)*', $filesize),\n      chr($bits_num), chr($bytes_num - 1),\n      join('', @{$uniq_bytes}), pack('B*', $bits_map);\n\n    while (my $size = read($fh, (my $chunk), CHUNK_SIZE)) {\n        print {$out_fh} scalar pack \"B*\", join('', @table{split //, $chunk});\n    }\n\n    return 1;\n}\n\nsub decompress_file {\n    my ($input, $output) = @_;\n\n    my $fh     = open_file('<:raw', $input);\n    my $out_fh = open_file('>:raw', $output);\n\n    valid_archive($fh) || die \"$0: file `$input' is not a TZP archive!\\n\";\n\n    my $fsize_len = do { read($fh, (my $byte), 1); ord $byte };\n    my $filesize  = do {\n        read($fh, (my $bytes), $fsize_len);\n\n        my @bytes = unpack('C*', $bytes);\n        foreach my $i (0 .. $#bytes - 1) {\n            length($bytes[$i]) != 2 && do { $bytes[$i] = sprintf('%02d', $bytes[$i]) }\n        }\n\n        join('', @bytes);\n    };\n\n    my $bits_num  = do { read($fh, (my $byte), 1); ord $byte };\n    my $bytes_num = do { read($fh, (my $byte), 1); 1 + ord $byte };\n\n    $DEBUG\n      && info(\n              bytes_num => $bytes_num,\n              bits_num  => $bits_num,\n              input     => $input,\n              output    => $output,\n              filesize  => $filesize,\n              compress  => 'false',\n             );\n\n    my $bytes = do { read($fh, (my $bytes), $bytes_num); [split(//, $bytes)] };\n\n    my $bits_len = $bits_num * $bytes_num;\n    if ((my $mod = $bits_len % 8) != 0) {\n        $bits_len += 8 - $mod;\n    }\n\n    my $bits = do { read($fh, my ($bytes), $bits_len / 8); unpack 'B*', $bytes };\n\n    my %table;\n    foreach my $byte (@{$bytes}) {\n        $table{substr($bits, 0, $bits_num, '')} = $byte;\n    }\n\n    my $bit_counter = 0;\n    my $prev_bits   = '';\n    while (my $size = read($fh, (my $chunk), CHUNK_SIZE)) {\n\n        $bit_counter += $size * 8;\n        my $bits     = $prev_bits . unpack \"B*\", $chunk;\n        my $bits_len = ($size * 8 + length($prev_bits));\n\n        if ($bit_counter / $bits_num - $filesize == 1) {\n            chop($bits), $bits_len-- for (1 .. $bits_num);\n        }\n        elsif ($bits_num < 8 && $bit_counter % $bits_num != 0 && eof($fh)) {\n            chop($bits), $bits_len-- for (1 .. $bit_counter % $bits_num);\n        }\n\n        my $sequence = '';\n        foreach (1 .. $bits_len / $bits_num) {\n            $sequence .= $table{substr($bits, 0, $bits_num, '')};\n        }\n\n        print {$out_fh} $sequence;\n        $prev_bits = $bits;\n    }\n\n    return 1;\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Compression/unzip.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 20 November 2024\n# https://github.com/trizen\n\n# Basic implementation of a ZIP file extractor.\n\n# Reference:\n#   https://pkware.cachefly.net/webdocs/casestudies/APPNOTE.TXT\n\nuse 5.036;\nuse Compression::Util     qw(:all);\nuse File::Path            qw(make_path);\nuse File::Spec::Functions qw(catfile catdir);\nuse File::Basename        qw(dirname);\n\nlocal $Compression::Util::LZ_MIN_LEN  = 4;        # minimum match length in LZ parsing\nlocal $Compression::Util::LZ_MAX_LEN  = 258;      # maximum match length in LZ parsing\nlocal $Compression::Util::LZ_MAX_DIST = 32768;    # maximum allowed back-reference distance in LZ parsing\n\nmy $output_directory = 'OUTPUT';\n\nif (not -d $output_directory) {\n    make_path($output_directory);\n}\n\nsub extract_file($fh) {\n\n    my $version_needed           = bytes2int_lsb($fh, 2);\n    my $general_purpose_bit_flag = bytes2int_lsb($fh, 2);\n    my $compression_method       = bytes2int_lsb($fh, 2);\n\n    my $last_mod_file_time = bytes2int_lsb($fh, 2);\n    my $last_mod_file_date = bytes2int_lsb($fh, 2);\n    my $crc32              = bytes2int_lsb($fh, 4);\n    my $compressed_size    = bytes2int_lsb($fh, 4);\n    my $uncompressed_size  = bytes2int_lsb($fh, 4);\n    my $file_name_length   = bytes2int_lsb($fh, 2);\n    my $extra_field_length = bytes2int_lsb($fh, 2);\n\n    my $skip_crc32 = 0;\n\n    if ($general_purpose_bit_flag & 0b1000) {\n        $skip_crc32 = 1;\n        $crc32 == 0             or warn \"[WARNING] Bit 3 is set, therefore CRC-32 must be set to zero (got: $crc32)\\n\";\n        $compressed_size == 0   or warn \"[WARNING] Bit 3 is set, thefore compressed size must be set to zero (got: $compressed_size)\\n\";\n        $uncompressed_size == 0 or warn \"[WARNING] Bit 3 is set, therefore uncompressed size must be set to zero (got: $uncompressed_size)\\n\";\n    }\n\n    read($fh, (my $file_name),   $file_name_length);\n    read($fh, (my $extra_field), $extra_field_length);\n\n    if ($general_purpose_bit_flag & 0x01) {\n        die \"Encrypted file are currently not supported!\\n\";\n    }\n\n    say STDERR \":: Extracting: $file_name ($uncompressed_size bytes)\";\n\n    # It's a directory\n    if ($uncompressed_size == 0 and substr($file_name, -1) eq '/') {\n        my $dir = catdir($output_directory, $file_name);\n        make_path($dir) if not -d $dir;\n        return 1;\n    }\n\n    my $out_filename = catfile($output_directory, $file_name);\n\n    my $out_dir = dirname($out_filename);\n    make_path($out_dir) if not -d $out_dir;\n\n    open my $out_fh, '>:raw', $out_filename\n      or die \"Can't create file <<$out_filename>>: $!\\n\";\n\n    my $actual_crc32             = 0;\n    my $buffer                   = '';\n    my $search_window            = '';\n    my $actual_uncompressed_size = 0;\n\n    if ($compression_method == 8) {    # DEFLATE method\n        while (1) {\n            my $is_last = read_bit_lsb($fh, \\$buffer);\n            my $chunk   = deflate_extract_next_block($fh, \\$buffer, \\$search_window);\n            $actual_crc32 = crc32($chunk, $actual_crc32);\n            $actual_uncompressed_size += length($chunk);\n            print $out_fh $chunk;\n            last if $is_last;\n        }\n    }\n    elsif ($compression_method == 0) {    # uncompressed (stored)\n\n        # TODO: do not read the entire content at once (read in small chunks)\n        read($fh, (my $chunk), $uncompressed_size);\n        $actual_crc32 = crc32($chunk);\n        $actual_uncompressed_size += length($chunk);\n        print $out_fh $chunk;\n    }\n    else {\n        die \"Unsupported compression method: $compression_method\\n\";\n    }\n\n    if (not $skip_crc32 and $crc32 != $actual_crc32) {\n        die \"CRC32 error: $crc32 (stored) != $actual_crc32 (actual)\\n\";\n    }\n\n    if ($general_purpose_bit_flag & 0b100) {    # TODO\n        die \"Data descriptor is currently not supported!\\n\";\n    }\n\n    if ($skip_crc32) {\n        my $header_signature = bytes2int_lsb($fh, 4);\n        if ($header_signature == 0x8074b50) {\n\n            my $stored_crc32      = bytes2int_lsb($fh, 4);\n            my $compressed_size   = bytes2int_lsb($fh, 4);\n            my $uncompressed_size = bytes2int_lsb($fh, 4);\n\n            if ($stored_crc32 != $actual_crc32) {\n                die \"CRC32 error: $stored_crc32 (stored) != $actual_crc32 (actual)\\n\";\n            }\n\n            if ($uncompressed_size != $actual_uncompressed_size) {\n                die \"Uncompressed size error: $uncompressed_size (stored) != $actual_uncompressed_size (actual)\\n\";\n            }\n        }\n        else {\n            die \"Unknown signature: $header_signature\\n\";\n        }\n    }\n\n    close $out_fh;\n    return $actual_crc32;\n}\n\nsub extract_central_directory($fh) {    # TODO\n\n    my $version_made_by                 = bytes2int_lsb($fh, 2);\n    my $version_needed_to_extract       = bytes2int_lsb($fh, 2);\n    my $general_purpose_bit_flag        = bytes2int_lsb($fh, 2);\n    my $compression_method              = bytes2int_lsb($fh, 2);\n    my $last_mod_file_time              = bytes2int_lsb($fh, 2);\n    my $last_mod_file_date              = bytes2int_lsb($fh, 2);\n    my $crc_32                          = bytes2int_lsb($fh, 4);\n    my $compressed_size                 = bytes2int_lsb($fh, 4);\n    my $uncompressed_size               = bytes2int_lsb($fh, 4);\n    my $file_name_length                = bytes2int_lsb($fh, 2);\n    my $extra_field_length              = bytes2int_lsb($fh, 2);\n    my $file_comment_length             = bytes2int_lsb($fh, 2);\n    my $disk_number_start               = bytes2int_lsb($fh, 2);\n    my $internal_file_attributes        = bytes2int_lsb($fh, 2);\n    my $external_file_attributes        = bytes2int_lsb($fh, 4);\n    my $relative_offset_of_local_header = bytes2int_lsb($fh, 4);\n\n    read($fh, (my $file_name),    $file_name_length);\n    read($fh, (my $extra_field),  $extra_field_length);\n    read($fh, (my $file_comment), $file_comment_length);\n}\n\nsub extract_end_of_file ($fh) {    # TODO\n\n    my $number_of_this_disk            = bytes2int_lsb($fh, 2);\n    my $number_of_the_disk_central_dir = bytes2int_lsb($fh, 2);\n    my $start_of_central_dir           = bytes2int_lsb($fh, 2);\n    my $total_number_of_entries        = bytes2int_lsb($fh, 2);\n    my $size_of_the_central_directory  = bytes2int_lsb($fh, 4);\n    my $offset                         = bytes2int_lsb($fh, 4);\n    my $ZIP_file_comment_length        = bytes2int_lsb($fh, 2);\n\n    read($fh, (my $ZIP_file_comment), $ZIP_file_comment_length);\n}\n\nsub unzip($file) {\n\n    open my $fh, '<:raw', $file\n      or die \"Can't open file <<$file>> for reading: $!\";\n\n    while (!eof($fh)) {\n        my $header_signature = bytes2int_lsb($fh, 4);\n\n        if ($header_signature == 0x04034b50) {\n            extract_file($fh);\n        }\n        elsif ($header_signature == 0x02014b50) {\n            extract_central_directory($fh);\n        }\n        elsif ($header_signature == 0x05054b50) {    # TODO\n            die \"Digital signature is currently not supported!\\n\";\n        }\n        elsif ($header_signature == 0x06064b50) {    # TODO\n            die \"ZIP64 is currently not supported!\\n\";\n        }\n        elsif ($header_signature == 0x08064b50) {    # TODO\n            die \"Extra data record is currently not supported!\\n\";\n        }\n        elsif ($header_signature == 0x06054b50) {\n            extract_end_of_file($fh);\n        }\n        else {\n            die \"Unknown header signature: $header_signature\\n\";\n        }\n    }\n}\n\nforeach my $input_file (@ARGV) {\n    unzip($input_file);\n}\n"
  },
  {
    "path": "Compression/zip.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 03 February 2025\n# Edit: 04 February 2025\n# https://github.com/trizen\n\n# Basic implementation of a ZIP archiver. (WIP)\n\n# Reference:\n#   https://pkware.cachefly.net/webdocs/casestudies/APPNOTE.TXT\n\nuse 5.036;\nuse Compression::Util     qw(:all);\nuse File::Path            qw(make_path);\nuse File::Spec::Functions qw(catfile catdir);\nuse File::Basename        qw(dirname);\nuse File::Find            qw(find);\n\nuse constant {\n              FORMAT     => 'zip',\n              CHUNK_SIZE => (1 << 15) - 1,\n             };\n\nlocal $Compression::Util::LZ_MIN_LEN  = 4;        # minimum match length in LZ parsing\nlocal $Compression::Util::LZ_MAX_LEN  = 258;      # maximum match length in LZ parsing\nlocal $Compression::Util::LZ_MAX_DIST = 32768;    # maximum allowed back-reference distance in LZ parsing\n\nbinmode(STDOUT, ':raw');\nbinmode(STDIN,  ':raw');\n\nmy $OFFSET = 0;\n\nsub zip_directory ($dir) {\n\n    if (substr($dir, 0, -1) ne '/') {\n        $dir .= '/';\n    }\n\n    print STDOUT int2bytes_lsb(0x04034b50,   4);    # header signature\n    print STDOUT int2bytes_lsb(20,           2);    # version needed\n    print STDOUT int2bytes_lsb(0,            2);    # general purpose bit\n    print STDOUT int2bytes_lsb(0,            2);    # compression method (8 = DEFLATE)\n    print STDOUT int2bytes_lsb(0,            2);    # last mod file time\n    print STDOUT int2bytes_lsb(0,            2);    # last mod file date\n    print STDOUT int2bytes_lsb(0,            4);    # CRC32\n    print STDOUT int2bytes_lsb(0,            4);    # compressed size\n    print STDOUT int2bytes_lsb(0,            4);    # uncompressed size\n    print STDOUT int2bytes_lsb(length($dir), 2);    # filename length\n    print STDOUT int2bytes_lsb(0,            2);    # extra field length\n\n    print STDOUT $dir;\n\n    my $info = {\n                crc32              => 0,\n                name               => $dir,\n                compressed_size    => 0,\n                uncompressed_size  => 0,\n                compression_method => 0,\n                offset             => $OFFSET,\n               };\n\n    $OFFSET += 4 * 4 + 2 * 7 + length($dir);\n\n    return $info;\n}\n\nsub zip_file ($file) {\n\n    if (-d $file) {\n        return zip_directory($file);\n    }\n\n    print STDOUT int2bytes_lsb(0x04034b50,    4);    # header signature\n    print STDOUT int2bytes_lsb(20,            2);    # version needed\n    print STDOUT int2bytes_lsb(0b1000,        2);    # general purpose bit\n    print STDOUT int2bytes_lsb(8,             2);    # compression method (8 = DEFLATE)\n    print STDOUT int2bytes_lsb(0,             2);    # last mod file time\n    print STDOUT int2bytes_lsb(0,             2);    # last mod file date\n    print STDOUT int2bytes_lsb(0,             4);    # CRC32\n    print STDOUT int2bytes_lsb(0,             4);    # compressed size\n    print STDOUT int2bytes_lsb(0,             4);    # uncompressed size\n    print STDOUT int2bytes_lsb(length($file), 2);    # filename length\n    print STDOUT int2bytes_lsb(0,             2);    # extra field length\n\n    print STDOUT $file;                              # filename\n\n    my $crc32             = 0;\n    my $uncompressed_size = 0;\n    my $compressed_size   = 0;\n\n    my $bitstring = '';\n\n    open my $in_fh, '<:raw', $file;\n\n    if (eof($in_fh)) {                               # empty file\n        $bitstring = '1' . '10' . '0000000';\n    }\n\n    while (read($in_fh, (my $chunk), CHUNK_SIZE)) {\n\n        $crc32 = crc32($chunk, $crc32);\n        $uncompressed_size += length($chunk);\n\n        my ($literals, $distances, $lengths) = lzss_encode($chunk);\n\n        $bitstring .= eof($in_fh) ? '1' : '0';\n\n        my $bt1_bitstring = deflate_create_block_type_1($literals, $distances, $lengths);\n\n        # When block type 1 is larger than the input, then we have random uncompressible data: use block type 0\n        if ((length($bt1_bitstring) >> 3) > length($chunk) + 5) {\n\n            say STDERR \":: Using block type: 0\";\n\n            $bitstring .= '00';\n\n            my $comp = pack('b*', $bitstring);    # pads to a byte\n            $comp            .= pack('b*', deflate_create_block_type_0_header($chunk));\n            $comp            .= $chunk;\n            $compressed_size .= length($comp);\n            print STDOUT $comp;\n\n            $bitstring = '';\n            next;\n        }\n\n        my $bt2_bitstring = deflate_create_block_type_2($literals, $distances, $lengths);\n\n        # When block type 2 is larger than block type 1, then we may have very small data\n        if (length($bt2_bitstring) > length($bt1_bitstring)) {\n            say STDERR \":: Using block type: 1\";\n            $bitstring .= $bt1_bitstring;\n        }\n        else {\n            say STDERR \":: Using block type: 2\";\n            $bitstring .= $bt2_bitstring;\n        }\n\n        my $comp = pack('b*', substr($bitstring, 0, length($bitstring) - (length($bitstring) % 8), ''));\n        $compressed_size += length($comp);\n        print STDOUT $comp;\n    }\n\n    if ($bitstring ne '') {\n        my $comp = pack('b*', $bitstring);\n        $compressed_size += length($comp);\n        print STDOUT $comp;\n    }\n\n    print STDOUT int2bytes_lsb(0x8074b50,          4);\n    print STDOUT int2bytes_lsb($crc32,             4);\n    print STDOUT int2bytes_lsb($compressed_size,   4);\n    print STDOUT int2bytes_lsb($uncompressed_size, 4);\n\n    my $info = {\n                compression_method => 8,\n                crc32              => $crc32,\n                name               => $file,\n                compressed_size    => $compressed_size,\n                uncompressed_size  => $uncompressed_size,\n                offset             => $OFFSET,\n               };\n\n    $OFFSET += 4 * 8 + 2 * 7 + length($file) + $compressed_size;\n\n    return $info;\n}\n\nsub central_directory($entry) {\n\n    # FIXME: the offset of the local header is incorrect\n\n    print STDOUT int2bytes_lsb(0x02014b50,                   4);    # header signature\n    print STDOUT int2bytes_lsb(831,                          2);    # version made by\n    print STDOUT int2bytes_lsb(20,                           2);    # version needed to extract\n    print STDOUT int2bytes_lsb(0,                            2);    # general purpose bit\n    print STDOUT int2bytes_lsb($entry->{compression_method}, 2);    # compression method\n    print STDOUT int2bytes_lsb(0,                            2);    # last mod file time\n    print STDOUT int2bytes_lsb(0,                            2);    # last mod file date\n    print STDOUT int2bytes_lsb($entry->{crc32},              4);    # crc32\n    print STDOUT int2bytes_lsb($entry->{compressed_size},    4);    # compressed size\n    print STDOUT int2bytes_lsb($entry->{uncompressed_size},  4);    # uncompressed size\n    print STDOUT int2bytes_lsb(length($entry->{name}),       2);    # file name length\n    print STDOUT int2bytes_lsb(0,                            2);    # extra field length\n    print STDOUT int2bytes_lsb(0,                            2);    # file comment length\n    print STDOUT int2bytes_lsb(0,                            2);    # disk number start\n    print STDOUT int2bytes_lsb(0,                            2);    # internal file attributes\n    print STDOUT int2bytes_lsb(0,                            4);    # external file attributes\n    print STDOUT int2bytes_lsb($entry->{offset},             4);    # relative offset of local header (TODO)\n\n    print STDOUT $entry->{name};\n}\n\nsub end_of_zip_file (@entries) {\n\n    print STDOUT int2bytes_lsb(0x06054b50,       4);                # header signature\n    print STDOUT int2bytes_lsb(0,                2);                # number of this disk\n    print STDOUT int2bytes_lsb(0,                2);                # number of the disk central dir\n    print STDOUT int2bytes_lsb(0,                2);                # start of central dir\n    print STDOUT int2bytes_lsb(scalar(@entries), 2);                # total number of entries\n    print STDOUT int2bytes_lsb(0,                4);                # size of the central directory\n    print STDOUT int2bytes_lsb(0,                4);                # offset\n    print STDOUT int2bytes_lsb(0,                2);                # zip file comment length\n}\n\nmy @entries;\n\nsub zip ($file) {\n    find(\n        {\n         no_chdir => 1,\n         wanted   => sub {\n             push @entries, zip_file($_);\n         }\n        },\n        $file\n    );\n}\n\nzip($ARGV[0]);\n\n#~ foreach my $entry(@entries) {\n#~ central_directory($entry);\n#~ }\n\n#~ end_of_zip_file(@entries);\n"
  },
  {
    "path": "Compression/zlib_compressor.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 05 November 2024\n# https://github.com/trizen\n\n# Basic implementation of the ZLIB Compressed Data Format.\n\n# Reference:\n#   https://datatracker.ietf.org/doc/html/rfc1950\n\n# Usage:\n#   perl zlib_compressor.pl < input_file.txt | zlib-flate -uncompress\n\nuse 5.036;\nuse Compression::Util qw(:all);\n\nlocal $Compression::Util::LZ_MIN_LEN  = 4;                # minimum match length in LZ parsing\nlocal $Compression::Util::LZ_MAX_LEN  = 258;              # maximum match length in LZ parsing\nlocal $Compression::Util::LZ_MAX_DIST = (1 << 15) - 1;    # maximum allowed back-reference distance in LZ parsing\n\nlocal $Compression::Util::VERBOSE = 1;\n\nbinmode(STDIN,  ':raw');\nbinmode(STDOUT, ':raw');\n\nsub zlib_compress ($in_fh, $out_fh) {\n\n    my $CMF = (7 << 4) | 8;\n    my $FLG = 2 << 6;\n\n    while (($CMF * 256 + $FLG) % 31 != 0) {\n        ++$FLG;\n    }\n\n    state $CHUNK_SIZE = (1 << 15) - 1;\n\n    my $bitstring = '';\n    my $adler32   = 1;\n\n    print $out_fh chr($CMF);\n    print $out_fh chr($FLG);\n\n    while (read($in_fh, (my $chunk), $CHUNK_SIZE)) {\n\n        my ($literals, $distances, $lengths) = lzss_encode($chunk);\n\n        $adler32 = adler32($chunk, $adler32);\n        $bitstring .= eof($in_fh) ? '1' : '0';\n        $bitstring .= deflate_create_block_type_2($literals, $distances, $lengths);\n\n        print $out_fh pack('b*', substr($bitstring, 0, length($bitstring) - (length($bitstring) % 8), ''));\n    }\n\n    if ($bitstring ne '') {\n        print $out_fh pack('b*', $bitstring);\n    }\n\n    print $out_fh int2bytes($adler32, 4);\n}\n\nzlib_compress(\\*STDIN, \\*STDOUT);\n"
  },
  {
    "path": "Compression/zlib_decompressor.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 06 November 2024\n# https://github.com/trizen\n\n# Basic decompressor for the ZLIB Compressed Data Format.\n\n# Reference:\n#   https://datatracker.ietf.org/doc/html/rfc1950\n\n# Usage:\n#   zlib-flate -compress=9 < /usr/bin/fdf | perl zlib_decompressor.pl\n\nuse 5.036;\nuse Compression::Util qw(:all);\n\nlocal $Compression::Util::LZ_MIN_LEN  = 4;                # minimum match length in LZ parsing\nlocal $Compression::Util::LZ_MAX_LEN  = 258;              # maximum match length in LZ parsing\nlocal $Compression::Util::LZ_MAX_DIST = (1 << 15) - 1;    # maximum allowed back-reference distance in LZ parsing\n\nlocal $Compression::Util::VERBOSE = 1;\n\nbinmode(STDIN,  ':raw');\nbinmode(STDOUT, ':raw');\n\nsub zlib_decompress ($in_fh, $out_fh) {\n\n    my $adler32 = 1;\n\n    my $CMF = ord(getc($in_fh));\n    my $FLG = ord(getc($in_fh));\n\n    if (($CMF * 256 + $FLG) % 31 != 0) {\n        die \"Invalid header checksum!\\n\";\n    }\n\n    my $CINFO = $CMF >> 4;\n\n    if ($CINFO > 7) {\n        die \"Values of CINFO above 7 are not supported!\\n\";\n    }\n\n    my $method = $CMF & 0b1111;\n\n    if ($method != 8) {\n        die \"Only method 8 (DEFLATE) is supported!\\n\";\n    }\n\n    my $buffer        = '';\n    my $search_window = '';\n\n    while (1) {\n\n        my $is_last = read_bit_lsb($in_fh, \\$buffer);\n        my $chunk   = deflate_extract_next_block($in_fh, \\$buffer, \\$search_window);\n\n        print $out_fh $chunk;\n        $adler32 = adler32($chunk, $adler32);\n\n        last if $is_last;\n    }\n\n    my $stored_adler32 = bytes2int($in_fh, 4);\n\n    if ($adler32 != $stored_adler32) {\n        die \"Adler32 checksum does not match: $adler32 (actual) != $stored_adler32 (stored)\\n\";\n    }\n\n    if (eof($in_fh)) {\n        print STDERR \"\\n:: Reached the end of the file.\\n\";\n    }\n    else {\n        print STDERR \"\\n:: There is something else in the container! Trying to recurse!\\n\\n\";\n        __SUB__->($in_fh, $out_fh);\n    }\n}\n\nzlib_decompress(\\*STDIN, \\*STDOUT);\n"
  },
  {
    "path": "Compression/zlib_file_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 05 May 2024\n# Edit: 06 November 2024\n# https://github.com/trizen\n\n# A valid Gzip file compressor/decompressor, generating DEFLATE blocks of type 0, 1 or 2, whichever is smaller.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip)\n#   https://youtube.com/watch?v=SJPvNi4HrWQ\n\nuse 5.036;\nuse File::Basename    qw(basename);\nuse Compression::Util qw(:all);\nuse List::Util        qw(all min max);\nuse Getopt::Std       qw(getopts);\n\nuse constant {\n              FORMAT     => 'zlib',\n              CHUNK_SIZE => (1 << 15) - 1,\n             };\n\nlocal $Compression::Util::LZ_MIN_LEN       = 4;                # minimum match length in LZ parsing\nlocal $Compression::Util::LZ_MAX_LEN       = 258;              # maximum match length in LZ parsing\nlocal $Compression::Util::LZ_MAX_DIST      = (1 << 15) - 1;    # maximum allowed back-reference distance in LZ parsing\nlocal $Compression::Util::LZ_MAX_CHAIN_LEN = 64;               # how many recent positions to remember in LZ parsing\n\nlocal $Compression::Util::VERBOSE = 1;\n\nmy ($DISTANCE_SYMBOLS, $LENGTH_SYMBOLS, $LENGTH_INDICES) = make_deflate_tables();\n\nsub usage ($code = 0) {\n    print <<\"EOH\";\nusage: $0 [options] [input file] [output file]\n\noptions:\n        -e            : extract\n        -i <filename> : input filename\n        -o <filename> : output filename\n        -r            : rewrite output\n        -h            : this message\n\nexamples:\n         $0 document.txt\n         $0 document.txt archive.${\\FORMAT}\n         $0 archive.${\\FORMAT} document.txt\n         $0 -e -i archive.${\\FORMAT} -o document.txt\n\nEOH\n\n    exit($code // 0);\n}\n\n#################\n# GZIP COMPRESSOR\n#################\n\nsub my_zlib_compress ($in_fh, $out_fh) {\n\n    my $CMF = (7 << 4) | 8;\n    my $FLG = 2 << 6;\n\n    while (($CMF * 256 + $FLG) % 31 != 0) {\n        ++$FLG;\n    }\n\n    my $bitstring = '';\n    my $adler32   = 1;\n\n    print $out_fh chr($CMF);\n    print $out_fh chr($FLG);\n\n    while (read($in_fh, (my $chunk), CHUNK_SIZE)) {\n\n        my ($literals, $distances, $lengths) = lzss_encode($chunk);\n\n        $adler32 = adler32($chunk, $adler32);\n        $bitstring .= eof($in_fh) ? '1' : '0';\n        $bitstring .= deflate_create_block_type_2($literals, $distances, $lengths);\n\n        print $out_fh pack('b*', substr($bitstring, 0, length($bitstring) - (length($bitstring) % 8), ''));\n    }\n\n    if ($bitstring ne '') {\n        print $out_fh pack('b*', $bitstring);\n    }\n\n    print $out_fh int2bytes($adler32, 4);\n}\n\n###################\n# GZIP DECOMPRESSOR\n###################\n\nsub my_zlib_decompress ($in_fh, $out_fh) {\n\n    my $adler32 = 1;\n\n    my $CMF = ord(getc($in_fh));\n    my $FLG = ord(getc($in_fh));\n\n    if (($CMF * 256 + $FLG) % 31 != 0) {\n        die \"Invalid header checksum!\\n\";\n    }\n\n    my $CINFO = $CMF >> 4;\n\n    if ($CINFO > 7) {\n        die \"Values of CINFO above 7 are not supported!\\n\";\n    }\n\n    my $method = $CMF & 0b1111;\n\n    if ($method != 8) {\n        die \"Only method 8 (DEFLATE) is supported!\\n\";\n    }\n\n    my $buffer        = '';\n    my $search_window = '';\n\n    while (1) {\n\n        my $is_last = read_bit_lsb($in_fh, \\$buffer);\n        my $chunk   = deflate_extract_next_block($in_fh, \\$buffer, \\$search_window);\n\n        print $out_fh $chunk;\n        $adler32 = adler32($chunk, $adler32);\n\n        last if $is_last;\n    }\n\n    my $stored_adler32 = bytes2int($in_fh, 4);\n\n    if ($adler32 != $stored_adler32) {\n        die \"Adler32 checksum does not match: $adler32 (actual) != $stored_adler32 (stored)\\n\";\n    }\n\n    if (eof($in_fh)) {\n        print STDERR \"\\n:: Reached the end of the file.\\n\";\n    }\n    else {\n        print STDERR \"\\n:: There is something else in the container! Trying to recurse!\\n\\n\";\n        __SUB__->($in_fh, $out_fh);\n    }\n}\n\nsub main {\n    my %opt;\n    getopts('ei:o:vhr', \\%opt);\n\n    $opt{h} && usage(0);\n    $opt{v} && version();\n\n    my ($input, $output) = @ARGV;\n    $input  //= $opt{i} // usage(2);\n    $output //= $opt{o};\n\n    my $ext = qr{\\.${\\FORMAT}\\z}io;\n    if ($opt{e} || $input =~ $ext) {\n\n        if (not defined $output) {\n            ($output = basename($input)) =~ s{$ext}{}\n              || die \"$0: no output file specified!\\n\";\n        }\n\n        if (not $opt{r} and -e $output) {\n            print \"'$output' already exists! -- Replace? [y/N] \";\n            <STDIN> =~ /^y/i || exit 17;\n        }\n\n        open my $in_fh, '<:raw', $input\n          or die \"Can't open file <<$input>> for reading: $!\";\n\n        open my $out_fh, '>:raw', $output\n          or die \"Can't open file <<$output>> for writing: $!\";\n\n        my_zlib_decompress($in_fh, $out_fh)\n          || die \"$0: error: decompression failed!\\n\";\n    }\n    elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) {\n        $output //= basename($input) . '.' . FORMAT;\n\n        open my $in_fh, '<:raw', $input\n          or die \"Can't open file <<$input>> for reading: $!\";\n\n        open my $out_fh, '>:raw', $output\n          or die \"Can't open file <<$output>> for writing: $!\";\n\n        my_zlib_compress($in_fh, $out_fh)\n          || die \"$0: error: compression failed!\\n\";\n    }\n    else {\n        warn \"$0: don't know what to do...\\n\";\n        usage(1);\n    }\n}\n\nmain();\nexit(0);\n"
  },
  {
    "path": "Converters/another_notes_to_markdown.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 27 April 2024\n# https://github.com/trizen\n\n# Convert JSON data from the Android app \"Another notes\" to Markdown format.\n\n# See also:\n#   https://github.com/maltaisn/another-notes-app\n\nuse 5.036;\n\nuse JSON          qw(from_json);\nuse File::Slurper qw(read_text);\n\nbinmode(STDOUT, ':utf8');\nbinmode(STDERR, ':utf8');\n\nmy $json_file = $ARGV[0] // die \"usage: $0 [input.json]\\n\";\n\nmy $json  = read_text($json_file);\nmy $notes = from_json($json)->{notes} // die \"Invalid input file\";\n\nsub markdown_escape($str) {\n    $str =~ s/([-*_`\\\\()\\[\\]#])/\\\\$1/gr;\n}\n\nforeach my $key (1 .. 1e6) {\n    if (exists $notes->{$key}) {\n\n        my $note = $notes->{$key};\n\n        my $title   = markdown_escape($note->{title});\n        my $content = markdown_escape(unpack('A*', $note->{content}));\n\n        if ($title !~ /\\S/) {\n            $title = '...';\n        }\n\n        say \"# $title\\n\";\n\n        if ($note->{type} == 0) {\n            say(($content =~ s/\\R/\\n\\n/gr), \"\\n\");\n        }\n        elsif ($note->{type} == 1) {\n\n            my $meta    = from_json($note->{metadata});\n            my @list    = split(/\\R/, $content);\n            my $checked = $meta->{checked};\n\n            foreach my $i (0 .. $#list) {\n                say \"- [\", ($checked->[$i] ? 'x' : ' '), \"] $list[$i]\\n\";\n            }\n        }\n        else {\n            warn \"Unknown note type: $note->{type}\\n\";\n        }\n    }\n}\n"
  },
  {
    "path": "Converters/another_notes_to_material_notes.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 27 April 2024\n# Edit: 28 September 2024\n# https://github.com/trizen\n\n# Convert JSON data from the Android app \"Another notes\" to \"Material Notes\".\n\n# See also:\n#   https://github.com/maltaisn/another-notes-app\n#   https://github.com/maelchiotti/LocalMaterialNotes\n\nuse 5.036;\n\nuse JSON          qw(to_json from_json);\nuse File::Slurper qw(read_text);\n\nbinmode(STDOUT, ':utf8');\nbinmode(STDERR, ':utf8');\n\nmy $json_file = $ARGV[0] // die \"usage: $0 [input.json]\\n\";\n\nmy $json  = read_text($json_file);\nmy $notes = from_json($json)->{notes} // die \"Invalid input file\";\n\nmy %new_notes = (\n                 encrypted => JSON::false,\n                 notes     => [],\n                 version   => \"1.6.0\",\n                );\n\nforeach my $key (1 .. 1e6) {\n    if (exists $notes->{$key}) {\n\n        my $note = $notes->{$key};\n\n        my $title   = $note->{title};\n        my $content = $note->{content};\n\n        my %new_note = (\n                        title        => $title // '',\n                        pinned       => JSON::false,\n                        deleted      => JSON::false,\n                        created_time => ($note->{added}    =~ s{Z\\z}{}r),\n                        edited_time  => ($note->{modified} =~ s{Z\\z}{}r),\n                       );\n\n        if ($note->{type} == 0) {    # text\n            $new_note{content} = to_json([{insert => $content}]);\n        }\n        elsif ($note->{type} == 1) {    # checklist\n\n            my $meta    = from_json($note->{metadata});\n            my @list    = split(/\\R/, $content);\n            my $checked = $meta->{checked};\n\n            my @new_checklist;\n\n            foreach my $i (0 .. $#list) {\n                push @new_checklist, {insert => $list[$i]};\n                push @new_checklist,\n                  {\n                    attributes => {\n                                   block   => \"cl\",\n                                   checked => $checked->[$i] ? JSON::true : JSON::false,\n                                  },\n                    insert => \"\\n\",\n                  };\n            }\n\n            $new_note{content} = to_json(\\@new_checklist);\n        }\n        else {\n            warn \"Unknown note type: $note->{type}\\n\";\n        }\n\n        push @{$new_notes{notes}}, \\%new_note;\n    }\n}\n\nsay to_json(\\%new_notes);\n"
  },
  {
    "path": "Converters/any_to_3gp.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 10 June 2013\n# https://github.com/trizen\n\n#\n## Convert any media file to the 3gp mobile format.\n#\n\n# Requires ffmpeg compiled with '--enable-libopencore_amrnb'\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Getopt::Std           qw(getopts);\nuse File::Path            qw(make_path);\nuse File::Spec::Functions qw(catfile);\n\nmy %opt;\ngetopts('f:o:i:h', \\%opt);\n\nif ($opt{h} or not defined $opt{f}) {\n    print <<\"USAGE\";\nusage: $0 [options]\n\noptions:\n        -f format       : convert only this video formats (can be a regex)\n        -i input dir    : convert videos from this directory (default: '.')\n        -o output dir   : where to put the converted videos (default: '.')\n\nexample: perl $0 -f 'mp4|webm'  -i Videos/  -o 3GP_Videos/\nUSAGE\n\n    exit !$opt{h};\n}\n\nmy $output_dir   = $opt{o}                         // '.';\nmy $input_dir    = $opt{i}                         // '.';\nmy $input_format = eval { qr{\\.\\K(?:$opt{f})\\z}i } // die \"$0: Invalid regex: $@\";\n\nif (not -d $output_dir) {\n    make_path($output_dir)\n      or die \"$0: Can't create path '$output_dir': $!\\n\";\n}\n\nopendir(my $dir_h, $input_dir)\n  or die \"$0: Can't open dir '$input_dir': $!\\n\";\n\nwhile (defined(my $file = readdir $dir_h)) {\n\n    (my $output_file = $file) =~ s{$input_format}{3gp} or next;\n    -f -s (my $input_file = catfile($input_dir, $file)) or next;\n\n    system qw(ffmpeg -i), $input_file, qw(\n      -acodec    amr_nb\n      -ar          8000\n      -ac             1\n      -ab            32\n      -vcodec      h263\n      -s           qcif\n      -r             15\n    ), catfile($output_dir, $output_file);\n\n    if ($? != 0) {\n        die \"$0: ffmpeg exited with a non-zero code!\\n\";\n    }\n}\n\nclosedir($dir_h);\n"
  },
  {
    "path": "Converters/ass2srt.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 01 February 2022\n# https://github.com/trizen\n\n# Convert ASS/SSA subtitles to SRT.\n\n# See also:\n#   http://www.tcax.org/docs/ass-specs.htm\n#   http://matroska.sourceforge.net/technical/specs/subtitles/ssa.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nbinmode(STDOUT, ':utf8');\nbinmode(STDERR, ':utf8');\n\nsub parse_ASS_subtitle ($file) {\n\n    open my $fh, '<:crlf:utf8', $file\n      or die \"Can't open file <<$file>> for reading: $!\";\n\n    my %sections;\n    my $section = '';\n\n    while (my $line = <$fh>) {\n        if ($line =~ m{^\\[(.*?)\\]\\s*\\z}) {\n            $section = $1;\n        }\n        else {\n            push @{$sections{$section}}, $line;\n        }\n    }\n\n    close $fh;\n\n    my $events = $sections{\"Events\"} // die \"No <<Events>> section found.\";\n    my $format = shift(@$events);\n\n    my @fields;\n\n    if ($format =~ m{^Format: (.+)}) {\n        @fields = split(/\\s*,\\s*/, $1);\n    }\n    else {\n        die \"Can't find the <<Format>> line\";\n    }\n\n    my @dialogues;\n\n    foreach my $event (@$events) {\n        if ($event =~ /^Dialogue: (.+)/) {\n            my @values = split(/\\s*,\\s*/, $1, scalar(@fields));\n\n            my %dialogue;\n            @dialogue{@fields} = @values;\n\n            push @dialogues, \\%dialogue;\n        }\n        else {\n            warn \"Ignoring line: $event\";\n        }\n    }\n\n    return @dialogues;\n}\n\nsub ASS_time_to_sec ($time) {\n    my ($hours, $min, $sec, $milisec) = split(/[:.]/, $time, 4);\n    ($hours * 3600 + $min * 60 + $sec + $milisec / 10**length($milisec));\n}\n\nsub sec_to_SRT_time ($sec) {\n    $sec = sprintf('%.3f', $sec);\n    sprintf('%02d:%02d:%02d,%03d', int($sec / 3600) % 24, int($sec / 60) % 60, $sec % 60, substr($sec, -3));\n}\n\nsub reformat_text ($text) {\n\n    $text =~ s{\\{\\\\i0\\}}{</i>}g;\n    $text =~ s{\\{\\\\b0\\}}{</b>}g;\n\n    $text =~ s{\\{\\\\i\\d+\\}}{<i>}g;\n    $text =~ s{\\{\\\\b\\d+\\}}{<b>}g;\n\n    # Strip unknown style codes\n    $text =~ s{\\{\\\\\\w.*?\\}}{}g;\n\n    # Replace \\N and \\n with a newline\n    $text =~ s{\\\\N}{\\n}g;\n    $text =~ s{\\\\n}{\\n}g;\n\n    # Replace \\h with a horizontal space\n    $text =~ s{\\\\h}{ }g;\n\n    $text;\n}\n\nsub reformat_time ($time) {\n    sec_to_SRT_time(ASS_time_to_sec($time));\n}\n\nsub ASS2SRT ($file) {\n\n    my @dialogues = parse_ASS_subtitle($file);\n\n    my $count = 1;\n    my @srt_data;\n\n    foreach my $entry (@dialogues) {\n\n        my $srt_entry = join(\"\\n\",\n                             $count++,\n                             join(' --> ', reformat_time($entry->{Start}), reformat_time($entry->{End})),\n                             reformat_text($entry->{Text}),\n                            );\n\n        push @srt_data, $srt_entry;\n    }\n\n    join(\"\\n\\n\", @srt_data) . \"\\n\\n\";\n}\n\nsub usage ($exit_code = 0) {\n    print <<\"EOT\";\nusage: $^X $0 [input.ass] [output.srt]\nEOT\n    exit($exit_code);\n}\n\nmy $input_file = shift(@ARGV) // usage(2);\nmy $srt_data   = ASS2SRT($input_file);\n\nmy $output_file = shift(@ARGV);\n\nif (defined($output_file)) {\n    open my $fh, '>:utf8', $output_file\n      or die \"Can't open file <<$output_file>> for writing: $!\";\n    print $fh $srt_data;\n    close $fh;\n}\nelse {\n    print $srt_data;\n}\n"
  },
  {
    "path": "Converters/code2pdf.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 30 July 2022\n# https://github.com/trizen\n\n# Code to PDF converter, with syntax highlighting, given a summary file.\n\n# Using the following tools:\n#   md2html         -- for converting Markdown to HTML (provided by md4c)\n#   markdown2pdf.pl -- for converting Markdown to PDF (with syntax highlighting)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse open IO => ':utf8', ':std';\nuse HTML::TreeBuilder 5 ('-weak');\n\nuse Encode       qw(decode_utf8 encode_utf8);\nuse Getopt::Long qw(GetOptions);\nuse URI::Escape  qw(uri_unescape);\nuse Digest::MD5  qw(md5_hex);\n\nmy $md2html      = \"md2html\";            # path to the `md2html` tool\nmy $markdown2pdf = \"markdown2pdf.pl\";    # path to the `markdown2pdf.pl` script\n\nmy $style     = 'github';\nmy $title     = 'Document';\nmy $lang      = 'perl';\nmy $page_size = 'A3';\nmy $mathjax   = 0;                       # true to use MathJax\n\nsub usage {\n    my ($exit_code) = @_;\n    $exit_code //= 0;\n\n    print <<\"EOT\";\nusage: $0 [options] [SUMMARY.md] [output.pdf]\n\noptions:\n\n    --style=s   : style theme for `highlight` (default: $style)\n    --title=s   : title of the PDF file (default: $title)\n    --lang=s    : language code used for highlighting (default: $lang)\n    --size=s    : set paper size to: A4, Letter, etc. (default: $page_size)\n    --mathjax!  : enable support for Tex expressions (default: $mathjax)\n\nEOT\n\n    exit($exit_code);\n}\n\nGetOptions(\n           \"style=s\"  => \\$style,\n           \"title=s\"  => \\$title,\n           \"lang=s\"   => \\$lang,\n           \"size=s\"   => \\$page_size,\n           \"mathjax!\" => \\$mathjax,\n           \"h|help\"   => sub { usage(0) },\n          )\n  or die(\"Error in command line arguments\\n\");\n\nmy $input_markdown_file = $ARGV[0] // usage(2);\nmy $output_pdf_file     = $ARGV[1] // \"OUTPUT.pdf\";\n\nsay \":: Converting <<$input_markdown_file>> to HTML...\";\nmy $html = `\\Q$md2html\\E \\Q$input_markdown_file\\E`;\n\nif ($? != 0) {\n    die \"`$md2html` failed with code: $?\";\n}\n\nmy $tree = HTML::TreeBuilder->new();\n$tree->parse($html);\n$tree->eof();\n\n#my @nodes = $tree->guts();\nmy @nodes = $tree->disembowel();\n\nmy %language_codes = (\n\n    # Source:\n    #   https://support.codebasehq.com/articles/tips-tricks/syntax-highlighting-in-markdown\n\n    Cucumber     => ['.feature'],\n    abap         => ['.abap'],\n    ada          => ['.adb',      '.ads', '.ada'],\n    ahk          => ['.ahk',      '.ahkl'],\n    apacheconf   => ['.htaccess', 'apache.conf', 'apache2.conf'],\n    applescript  => ['.applescript'],\n    as           => ['.as'],\n    as3          => ['.as'],\n    asy          => ['.asy'],\n    bash         => ['.sh',  '.ksh', '.bash', '.ebuild', '.eclass'],\n    bat          => ['.bat', '.cmd'],\n    befunge      => ['.befunge'],\n    blitzmax     => ['.bmx'],\n    boo          => ['.boo'],\n    brainfuck    => ['.bf',    '.b'],\n    c            => ['.c',     '.h'],\n    cfm          => ['.cfm',   '.cfml', '.cfc'],\n    cheetah      => ['.tmpl',  '.spt'],\n    cl           => ['.cl',    '.lisp', '.el'],\n    clojure      => ['.clj',   '.cljs'],\n    cmake        => ['.cmake', 'CMakeLists.txt'],\n    coffeescript => ['.coffee'],\n    console      => ['.sh-session'],\n    control      => ['control'],\n    cpp          => ['.cpp', '.hpp', '.c++', '.h++', '.cc', '.hh', '.cxx', '.hxx', '.pde'],\n    csharp       => ['.cs'],\n    css          => ['.css'],\n    cython       => ['.pyx', '.pxd', '.pxi'],\n    d            => ['.d',   '.di'],\n    delphi       => ['.pas'],\n    diff         => ['.diff',   '.patch'],\n    dpatch       => ['.dpatch', '.darcspatch'],\n    duel         => ['.duel',   '.jbst'],\n    dylan        => ['.dylan',  '.dyl'],\n    erb          => ['.erb'],\n    erl          => ['.erl-sh'],\n    erlang       => ['.erl', '.hrl'],\n    evoque       => ['.evoque'],\n    factor       => ['.factor'],\n    felix        => ['.flx', '.flxh'],\n    fortran      => ['.f',   '.f90'],\n    gas          => ['.s',   '.S'],\n    genshi       => ['.kid'],\n    glsl         => ['.vert', '.frag', '.geo'],\n    gnuplot      => ['.plot', '.plt'],\n    go           => ['.go'],\n    groff        => ['.1', '.2', '.3', '.4', '.5', '.6', '.7', '.man'],\n    haml         => ['.haml'],\n    haskell      => ['.hs'],\n    html         => ['.html', '.htm', '.xhtml', '.xslt'],\n    hx           => ['.hx'],\n    hybris       => ['.hy',  '.hyb'],\n    ini          => ['.ini', '.cfg'],\n    io           => ['.io'],\n    ioke         => ['.ik'],\n    irc          => ['.weechatlog'],\n    jade         => ['.jade'],\n    java         => ['.java'],\n    js           => ['.js'],\n    jsp          => ['.jsp'],\n    lhs          => ['.lhs'],\n    llvm         => ['.ll'],\n    logtalk      => ['.lgt'],\n    lua          => ['.lua', '.wlua'],\n    make         => ['.mak', 'Makefile', 'makefile', 'Makefile.', 'GNUmakefile'],\n    mako         => ['.mao'],\n    maql         => ['.maql'],\n    mason        => ['.mhtml', '.mc', '.mi', 'autohandler', 'dhandler'],\n    markdown     => ['.md'],\n    modelica     => ['.mo'],\n    modula2      => ['.def', '.mod'],\n    moocode      => ['.moo'],\n    mupad        => ['.mu'],\n    mxml         => ['.mxml'],\n    myghty       => ['.myt', 'autodelegate'],\n    nasm         => ['.asm', '.ASM'],\n    newspeak     => ['.ns2'],\n    objdump      => ['.objdump'],\n    objectivec   => ['.m'],\n    objectivej   => ['.j'],\n    ocaml        => ['.ml', '.mli', '.mll', '.mly'],\n    ooc          => ['.ooc'],\n    perl         => ['.pl',     '.PL',   '.perl', '.PERL', '.pm', '.pod', '.POD', '.t', '.cgi', '.fcgi'],\n    php          => ['.php',    '.php3', '.php4', '.php5'],\n    postscript   => ['.ps',     '.eps'],\n    pot          => ['.pot',    '.po'],\n    pov          => ['.pov',    '.inc'],\n    prolog       => ['.prolog', '.pro'],\n    properties   => ['.properties'],\n    protobuf     => ['.proto'],\n    py3tb        => ['.py3tb'],\n    pytb         => ['.pytb'],\n    python       => ['.py', '.pyw', '.sc', 'SConstruct', 'SConscript', '.tac'],\n    ruby         => ['.rb', '.rbw', 'Rakefile', '.rake', '.gemspec', '.rbx', '.duby'],\n    rconsole     => ['.Rout'],\n    rebol        => ['.r', '.r3'],\n    redcode      => ['.cw'],\n    rhtml        => ['.rhtml'],\n    rst          => ['.rst', '.rest'],\n    sass         => ['.sass'],\n    scala        => ['.scala'],\n    scaml        => ['.scaml'],\n    scheme       => ['.scm'],\n    scss         => ['.scss'],\n    smalltalk    => ['.st'],\n    smarty       => ['.tpl'],\n    sourceslist  => ['sources.list'],\n    splus        => ['.S', '.R'],\n    sql          => ['.sql'],\n    sqlite3      => ['.sqlite3-console'],\n    squidconf    => ['squid.conf'],\n    ssp          => ['.ssp'],\n    tcl          => ['.tcl'],\n    tcsh         => ['.tcsh', '.csh'],\n    tex          => ['.tex',  '.aux', '.toc'],\n    text         => ['.txt'],\n    v            => ['.v',    '.sv'],\n    vala         => ['.vala', '.vapi'],\n    vbnet        => ['.vb',   '.bas'],\n    velocity     => ['.vm',   '.fhtml'],\n    vim          => ['.vim',  '.vimrc'],\n    xml          => ['.xml',  '.xsl', '.rss', '.xslt', '.xsd', '.wsdl'],\n    xquery       => ['.xqy',  '.xquery'],\n    xslt         => ['.xsl',  '.xslt'],\n    yaml         => ['.yaml', '.yml'],\n    julia        => ['.jl'],\n                     );\n\nsub determine_language_code {\n    my ($file) = @_;\n\n    my @found_codes;\n\n    foreach my $lang_code (keys %language_codes) {\n        foreach my $ext (@{$language_codes{$lang_code}}) {\n            if (substr($file, -length($ext)) eq $ext) {\n                push @found_codes, $lang_code;\n            }\n        }\n    }\n\n    if (scalar(@found_codes) == 1) {\n        return $found_codes[0];\n    }\n\n    if (scalar(@found_codes) > 1) {\n        warn \":: Ambiguous file extension for <<$file>>: it could be (@found_codes)\\n\";\n        @found_codes = sort @found_codes;    # be deterministic\n        return $found_codes[0];\n    }\n\n    return $lang;\n}\n\nsay \":: Reading Markdown files...\";\nmy $markdown_content = '';\n\nsub expand_ul {\n    my ($ul, $depth) = @_;\n\n    foreach my $t (@{$ul->content}) {\n        if ($t->tag eq 'li') {\n            foreach my $x (@{$t->content}) {\n\n                if (!ref($x)) {\n                    $markdown_content .= (\"#\" x $depth) . ' ' . $x . \"\\n\\n\";\n                    next;\n                }\n\n                if ($x->tag eq 'ul') {\n                    expand_ul($x, $depth + 1);\n                }\n                else {\n                    if ($x->tag eq 'a') {\n\n                        my $href = $x->attr('href');\n                        my $file = decode_utf8(uri_unescape($href));\n\n                        if (not -e $file) {\n                            warn \":: File <<$file>> does not exist. Skipping...\\n\";\n                            next;\n                        }\n\n                        if (-d $file) {\n                            $markdown_content .= (\"#\" x $depth) . ' ' . $x->content->[0] . \"\\n\\n\";\n                            next;\n                        }\n\n                        if (not -T $file) {\n                            warn \":: Ignoring binary file <<$file>>...\\n\";\n                            next;\n                        }\n\n                        if (open(my $fh, '<:utf8', $file)) {\n                            my $lang_code = determine_language_code($file);\n                            $markdown_content .= (\"#\" x $depth) . ' ' . $x->content->[0] . \"\\n\\n\";\n                            $markdown_content .= \"```$lang_code\\n\";\n                            $markdown_content .= do {\n                                local $/;\n                                <$fh>;\n                            };\n                            if (substr($markdown_content, -1) ne \"\\n\") {\n                                $markdown_content .= \"\\n\";\n                            }\n                            $markdown_content .= \"```\\n\\n\";\n                        }\n                        else {\n                            warn \":: Cannot open file <<$file>> for reading: $!\\n\";\n                        }\n                    }\n                }\n            }\n        }\n    }\n}\n\nforeach my $entry (@nodes) {\n    if ($entry->tag eq 'ul') {\n        expand_ul($entry, 1);\n    }\n}\n\nmy $markdown_file = \"$output_pdf_file.md\";\n\nopen my $fh, '>:utf8', $markdown_file\n  or die \"Can't open file <<$markdown_file>> for writing: $!\";\n\nprint $fh $markdown_content;\nclose $fh;\n\nsay \":: Converting Markdown to PDF...\";\nsystem($markdown2pdf, ($mathjax ? \"--mathjax\" : ()), \"--style\", $style, \"--title\", $title, \"--size\", $page_size, $markdown_file, $output_pdf_file);\n\nunlink($markdown_file);\n\nif ($? != 0) {\n    die \"`$markdown2pdf` failed with code: $?\";\n}\n"
  },
  {
    "path": "Converters/euler2pdf.pl",
    "content": "#!/usr/bin/perl\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse PDF::API2             qw();\nuse Text::Unidecode       qw(unidecode);\nuse HTML::Entities        qw(decode_entities);\nuse File::Spec::Functions qw(catfile tmpdir);\n\nmy $main_url = 'https://projecteuler.net/problem=%d';\n\nmy $p_beg = 1;\nmy $p_end = 679;\n\nmy $update_p_nums = 1;    # true to retrieve the current number of problems\n\nif ($update_p_nums) {\n\n    require LWP::UserAgent;\n    my $lwp = LWP::UserAgent->new(env_proxy => 1,\n                                  agent     => 'Mozilla/5.0 (X11; Linux x86_64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/46.0.2490.80 Safari/537.36',);\n\n    my $resp = $lwp->get('https://projecteuler.net/archives');\n    if ($resp->is_success) {\n        my $content = $resp->decoded_content;\n\n        if ($content =~ /The problems archives table shows problems (\\d+) to (\\d+)/) {\n            $p_beg = $1;\n            $p_end = $2;\n            say \"Successfully updated the number of problems ($p_beg to $p_end)\";\n        }\n        else {\n            warn \"Can't get the new number of problems. Using the default ones...\";\n        }\n    }\n}\n\nmy $page = 1;\nmy $pdf  = PDF::API2->new;\n\nmy $ms_delay     = 3500;                                    # wait some milliseconds for JavaScript to finish\nmy $outlines     = $pdf->outline;\nmy $cache_dir    = tmpdir();\nmy $outline_file = catfile($cache_dir, \"outline_$$.txt\");\n\nsub end {\n    $pdf->preferences(-outlines => 1, -onecolumn => 1);\n    $pdf->save('Project Euler.pdf');\n}\n\nlocal $SIG{INT} = \\&end;\n\nfor my $i ($p_beg .. $p_end) {\n\n    printf(\"[%3d of %3d] Processing...\\n\", $i, $p_end);\n\n    my $url      = sprintf($main_url, $i);\n    my $pdf_data = `wkhtmltopdf              \\\\\n        --dump-outline \\Q$outline_file\\E     \\\\\n        --quiet                              \\\\\n        --use-xserver                        \\\\\n        --enable-javascript                  \\\\\n        --enable-smart-shrinking             \\\\\n        --images                             \\\\\n        --enable-forms                       \\\\\n        --enable-plugins                     \\\\\n        --enable-external-links              \\\\\n        --load-error-handling ignore         \\\\\n        --javascript-delay $ms_delay         \\\\\n        --cache-dir \\Q$cache_dir\\E           \\\\\n        \\Q$url\\E                             \\\\\n        /dev/stdout`;\n\n    if (defined $pdf_data) {\n        my $pdf_obj = PDF::API2->from_string($pdf_data);\n\n        my $outline = $outlines->outline;\n        if (open my $fh, '<:utf8', $outline_file) {\n            while (<$fh>) {\n                if (/^\\h*<item title=\"(.*?)\" page=\"1\"/) {\n                    my $title = unidecode(decode_entities($1));\n                    $outline->title(\"$i. $title\");\n                    last;\n                }\n            }\n        }\n\n        my $start = $page;\n\n        for my $i (1 .. $pdf_obj->page_count) {\n            $pdf->import_page($pdf_obj, $i, $page);\n            ++$page;\n        }\n\n        $outline->destination($pdf->open_page($start));\n    }\n}\n\nend();\n"
  },
  {
    "path": "Converters/from_hex.pl",
    "content": "#!/usr/bin/perl\n\n# Convert HEX to binary.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Getopt::Long qw(GetOptions);\n\nmy $low_nybble = 0;\n\nGetOptions(\"l|low!\" => \\$low_nybble)\n  or die \"Error in arguments\";\n\nmy $hex_str = '';\n\nwhile (<>) {\n\n    # Make sure the line starts with an hexadecimal\n    if (/^[[:xdigit:]]/) {\n\n        # Collect all hexadecimal strings from the line\n        while (/([[:xdigit:]]+)/g) {\n            $hex_str .= $1;\n        }\n    }\n}\n\nbinmode(STDOUT, ':raw');\nprint pack(($low_nybble ? \"h*\" : \"H*\"), $hex_str);\n"
  },
  {
    "path": "Converters/gdbm_to_berkeley.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 03 April 2023\n# https://github.com/trizen\n\n# Convert a GDBM database to a Berkeley database.\n\nuse 5.036;\nuse DB_File;\nuse GDBM_File;\n\nscalar(@ARGV) == 2 or die \"usage: $0 [input.dbm] [output.dbm]\";\n\nmy $input_file  = $ARGV[0];\nmy $output_file = $ARGV[1];\n\nif (not -f $input_file) {\n    die \"Input file <<$input_file>> does not exist!\\n\";\n}\n\nif (-e $output_file) {\n    die \"Output file <<$output_file>> already exists!\\n\";\n}\n\ntie(my %input, 'GDBM_File', $input_file, &GDBM_READER, 0555)\n  or die \"Can't access database <<$input_file>>: $!\";\n\ntie(my %output, 'DB_File', $output_file, O_CREAT | O_RDWR, 0666, $DB_HASH)\n  or die \"Can't create database <<$output_file>>: $!\";\n\nwhile (my ($key, $value) = each %input) {\n    $output{$key} = $value;\n}\n\nuntie(%input);\nuntie(%output);\n"
  },
  {
    "path": "Converters/gitbook2pdf.pl",
    "content": "#~ #!/usr/bin/perl\n\n# Author: Trizen\n# Date: 30 July 2022\n# https://github.com/trizen\n\n# Gitbook to PDF converter, with syntax highlighting.\n\n# Uses the following tools:\n#   md2html         -- for converting Markdown to HTML (provided by md4c)\n#   markdown2pdf.pl -- for converting Markdown to PDF (with syntax highlighting)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse open IO => ':utf8', ':std';\nuse HTML::TreeBuilder 5 ('-weak');\n\nuse Encode       qw(decode_utf8 encode_utf8);\nuse Getopt::Long qw(GetOptions);\nuse URI::Escape  qw(uri_unescape);\nuse Digest::MD5  qw(md5_hex);\n\nmy $md2html      = \"md2html\";            # path to the `md2html` tool\nmy $markdown2pdf = \"markdown2pdf.pl\";    # path to the `markdown2pdf.pl` script\n\nmy $style     = 'github';\nmy $title     = 'Document';\nmy $page_size = \"A3\";\nmy $mathjax   = 0;                       # true to use MathJax\n\nsub usage {\n    my ($exit_code) = @_;\n    $exit_code //= 0;\n\n    print <<\"EOT\";\nusage: $0 [options] [SUMMARY.md] [output.pdf]\n\noptions:\n\n    --style=s   : style theme for `highlight` (default: $style)\n    --title=s   : title of the PDF file (default: $title)\n    --size=s    : set paper size to: A4, Letter, etc. (default: $page_size)\n    --mathjax!  : enable support for Tex expressions (default: $mathjax)\n\nEOT\n\n    exit($exit_code);\n}\n\nGetOptions(\n           \"style=s\"  => \\$style,\n           \"title=s\"  => \\$title,\n           \"size=s\"   => \\$page_size,\n           \"mathjax!\" => \\$mathjax,\n           \"h|help\"   => sub { usage(0) },\n          )\n  or die(\"Error in command line arguments\\n\");\n\nmy $input_markdown_file = $ARGV[0] // usage(2);\nmy $output_pdf_file     = $ARGV[1] // \"OUTPUT.pdf\";\n\nsay \":: Converting <<$input_markdown_file>> to HTML...\";\nmy $html = `\\Q$md2html\\E \\Q$input_markdown_file\\E`;\n\nif ($? != 0) {\n    die \"`$md2html` failed with code: $?\";\n}\n\nmy $tree = HTML::TreeBuilder->new();\n$tree->parse($html);\n$tree->eof();\n\n#my @nodes = $tree->guts();\nmy @nodes = $tree->disembowel();\n\nsay \":: Reading Markdown files...\";\nmy $markdown_content = '';\n\nsub expand_ul {\n    my ($ul, $depth) = @_;\n\n    foreach my $t (@{$ul->content}) {\n        if ($t->tag eq 'li') {\n            foreach my $x (@{$t->content}) {\n\n                if (!ref($x)) {\n                    next;\n                }\n\n                if ($x->tag eq 'ul') {\n                    expand_ul($x, $depth + 1);\n                }\n                else {\n                    if ($x->tag eq 'a') {\n\n                        my $href = $x->attr('href');\n                        my $file = decode_utf8(uri_unescape($href));\n\n                        if (not -e $file) {\n                            warn \":: File <<$file>> does not exist. Skipping...\\n\";\n                            next;\n                        }\n\n                        if (open my $fh, '<:utf8', $file) {\n                            local $/;\n                            $markdown_content .= <$fh>;\n                            $markdown_content .= \"\\n\\n\";\n                        }\n                        else {\n                            warn \":: Cannot open file <<$file>> for reading: $!\\n\";\n                        }\n                    }\n                }\n            }\n        }\n    }\n}\n\nforeach my $entry (@nodes) {\n    if ($entry->tag eq 'ul') {\n        expand_ul($entry, 1);\n    }\n}\n\nmy $markdown_file = \"$output_pdf_file.md\";\n\n$markdown_content =~ s{^####+ Output:$}{**Output:**}gm;\n\n$markdown_content =~ s{\n    \\[(\\d+)\\]:\\s*(https?://.+)\n    \\s*\\R\\s*\n    \\#\\s*\\[(.+?)\\]\\[\\1\\]\n}{\n    my $t = 'a'.md5_hex(encode_utf8($2));\n    \"[\". $t .\"]: $2\\n\\n# [$3][$t]\";\n}gex;\n\nopen my $fh, '>:utf8', $markdown_file\n  or die \"Can't open file <<$markdown_file>> for writing: $!\";\n\nprint $fh $markdown_content;\nclose $fh;\n\nsay \":: Converting Markdown to PDF...\";\nsystem($markdown2pdf, ($mathjax ? \"--mathjax\" : ()), \"--style\", $style, \"--title\", $title, \"--size\", $page_size, $markdown_file, $output_pdf_file);\n\nunlink($markdown_file);\n\nif ($? != 0) {\n    die \"`$markdown2pdf` failed with code: $?\";\n}\n"
  },
  {
    "path": "Converters/gz2xz.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 08 May 2024\n# https://github.com/trizen\n\n# Convert Gzip files to XZ.\n\nuse 5.036;\nuse IO::Compress::Xz       qw();\nuse IO::Uncompress::Gunzip qw();\nuse Getopt::Long           qw(GetOptions);\n\nuse constant {\n              CHUNK_SIZE => 1 << 16,    # how many bytes to read per chunk\n             };\n\nsub gz2xz ($in_fh, $out_fh) {\n\n    while ($in_fh->read(my $chunk, CHUNK_SIZE)) {\n        $out_fh->print($chunk);\n    }\n\n    $in_fh->eof   or return;\n    $in_fh->close or return;\n    $out_fh->close;\n}\n\nmy $keep_original = 0;\nmy $overwrite     = 0;\n\nsub usage ($exit_code) {\n    print <<\"EOT\";\nusage: $0 [options] [.gz files]\n\noptions:\n\n    -k --keep!          : keep the original Gzip files (default: $keep_original)\n    -f --force!         : overwrite existing files (default: $overwrite)\n    -h --help           : print this message and exit\n\nexample:\n\n    # Convert a bunch of Gzip files to XZ format\n    $0 *.gz\nEOT\n\n    exit($exit_code);\n}\n\nGetOptions(\n           'k|keep!'  => \\$keep_original,\n           'f|force!' => \\$overwrite,\n           'h|help'   => sub { usage(0) },\n          )\n  or usage(1);\n\n@ARGV || usage(2);\n\nforeach my $gz_file (@ARGV) {\n\n    if (not -f $gz_file) {\n        warn \":: Not a file: <<$gz_file>>. Skipping...\\n\";\n        next;\n    }\n\n    say \"\\n:: Processing: $gz_file\";\n\n    my $xz_file = $gz_file;\n\n    if (   $xz_file =~ s{\\.tgz\\z}{.txz}i\n        or $xz_file =~ s{\\.gz\\z}{.xz}i) {\n        ## ok\n    }\n    else {\n        $xz_file .= '.xz';\n    }\n\n    if (-e $xz_file) {\n        if (not $overwrite) {\n            say \"-> File <<$xz_file>> already exists. Skipping...\";\n            next;\n        }\n    }\n\n    my $in_fh = IO::Uncompress::Gunzip->new($gz_file) or do {\n        warn \"[!] Probably not a Gzip file ($IO::Uncompress::Gunzip::GunzipError). Skipping...\\n\";\n        next;\n    };\n\n    my $out_fh = IO::Compress::Xz->new($xz_file)\n      or die \"[!] Failed to initialize the compressor: $IO::Compress::Xz::XzError\\n\";\n\n    gz2xz($in_fh, $out_fh) || do {\n        warn \"[!] Something went wrong! Skipping...\\n\";\n        unlink($xz_file);\n        next;\n    };\n\n    my $old_size = -s $gz_file;\n    my $new_size = -s $xz_file;\n\n    say \"-> $old_size vs. $new_size\";\n\n    if (not $keep_original) {\n        say \"-> Removing the original Gzip file: $gz_file\";\n        unlink($gz_file) or warn \"[!] Can't remove file <<$gz_file>>: $!\\n\";\n    }\n}\n"
  },
  {
    "path": "Converters/html2pdf.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 16 April 2023\n# https://github.com/trizen\n\n# HTML|URL to PDF converter, with JavaScript support.\n\n# Using the following tool:\n#   wkhtmltopdf -- for converting HTML to PDF\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse open IO => ':utf8', ':std';\nuse Getopt::Long qw(GetOptions);\n\nmy $title     = undef;\nmy $js        = 0;\nmy $js_delay  = 1000;\nmy $page_size = 'A3';\n\nsub usage {\n    my ($exit_code) = @_;\n    $exit_code //= 0;\n\n    print <<\"EOT\";\nusage: $0 [options] [input.html | URL] [output.pdf]\n\noptions:\n\n    --js         : allow web pages to run JavaScript (default: $js)\n    --js-delay=i : wait some milliseconds for JavaScript to finish (default: $js_delay)\n    --title=s    : title of the PDF file\n    --size=s     : set paper size to: A4, Letter, etc. (default: $page_size)\n\nEOT\n\n    exit($exit_code);\n}\n\nGetOptions(\n           \"title=s\"        => \\$title,\n           \"size=s\"         => \\$page_size,\n           'js|javascript!' => \\$js,\n           'js-delay=i'     => \\$js_delay,\n           \"h|help\"         => sub { usage(0) },\n          )\n  or die(\"Error in command line arguments\\n\");\n\nmy $input_html_file = $ARGV[0] // usage(2);\nmy $output_pdf_file = $ARGV[1] // \"output.pdf\";\n\nsay \":: Converting HTML to PDF...\";\n\nsystem(\n    qw(wkhtmltopdf\n      --quiet\n      --enable-smart-shrinking\n      --images\n      --enable-external-links\n      --enable-internal-links\n      --keep-relative-links\n      --enable-local-file-access\n      --load-error-handling ignore),\n    \"--page-size\", $page_size,\n    (defined($title) ? ('--title', $title) : ()),\n    ($js             ? (\n            '--enable-javascript',\n            '--javascript-delay', $js_delay\n       ) : ('--disable-javascript')),\n    $input_html_file,\n    $output_pdf_file,\n);\n\nif ($? != 0) {\n    die \"`wkhtmltopdf` failed with code: $?\";\n}\n\nsay \":: Done!\"\n"
  },
  {
    "path": "Converters/html2pdf_chromium.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 16 April 2023\n# https://github.com/trizen\n\n# HTML|URL to PDF converter, with JavaScript support.\n\n# Using the following tool:\n#   chromium -- for converting HTML to PDF\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse open IO => ':utf8', ':std';\nuse Getopt::Long qw(GetOptions);\n\nmy $js_delay = 10000;\n\nsub usage {\n    my ($exit_code) = @_;\n    $exit_code //= 0;\n\n    print <<\"EOT\";\nusage: $0 [options] [input.html | URL] [output.pdf]\n\noptions:\n\n    --js-delay=i : wait some milliseconds for JavaScript to finish (default: $js_delay)\n\nEOT\n\n    exit($exit_code);\n}\n\nGetOptions('js-delay=i' => \\$js_delay,\n           \"h|help\"     => sub { usage(0) },)\n  or die(\"Error in command line arguments\\n\");\n\nmy $input_html_file = $ARGV[0] // usage(2);\nmy $output_pdf_file = $ARGV[1] // \"output.pdf\";\n\nsay \":: Converting HTML to PDF...\";\n\n# Reference:\n#   https://peter.sh/experiments/chromium-command-line-switches/\n\nsystem(\n    qw(\n      chromium\n      --headless\n      --disable-gpu\n      --no-pdf-header-footer\n      --disable-pdf-tagging\n      --enable-local-file-accesses\n      --run-all-compositor-stages-before-draw\n    ),\n    \"--virtual-time-budget=$js_delay\",\n    \"--print-to-pdf=$output_pdf_file\",\n    $input_html_file,\n);\n\nif ($? != 0) {\n    die \"`chromium` failed with code: $?\";\n}\n\nsay \":: Done!\"\n"
  },
  {
    "path": "Converters/html2text.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 08 January 2022\n# https://github.com/trizen\n\n# Convert HTML to text (UTF-8), given either an HTML file, or an URL.\n\n# Dependencies:\n#   perl-html-tree\n#   perl-html-formatter\n#   perl-libwww                 (optional: when given URLs)\n#   perl-lwp-protocol-https     (optional: when given https:// URLs)\n\n# See also:\n#   https://github.com/grobian/html2text\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse HTML::TreeBuilder 5 qw(-weak);\nuse HTML::FormatText    qw();\nuse Getopt::Long        qw(GetOptions);\n\nbinmode(STDIN,  ':utf8');\nbinmode(STDOUT, ':utf8');\n\nsub extract_html ($source) {\n\n    if ($source =~ m{^https?://}) {\n\n        require LWP::UserAgent;\n        require HTTP::Message;\n\n        my $lwp = LWP::UserAgent->new(\n                                      env_proxy  => 1,\n                                      timeout    => 15,\n                                      agent      => \"Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:91.0) Gecko/20100101 Firefox/91.0\",\n                                      cookie_jar => {},\n                                      ssl_opts   => {verify_hostname => 0},\n                                     );\n\n        state $accepted_encodings = HTTP::Message::decodable();\n        $lwp->default_header('Accept-Encoding' => $accepted_encodings);\n\n        my $resp = $lwp->get($source);\n        $resp->is_success or return;\n\n        my $html = $resp->decoded_content;\n        return $html;\n    }\n\n    if (ref($source) eq 'GLOB') {\n        my $html = do {\n            local $/;\n            <$source>;\n        };\n        return $html;\n    }\n\n    my $html = do {\n        open my $fh, '<:utf8', $source\n          or die \"Can't open file <<$source>> for reading: $!\";\n        local $/;\n        <$fh>;\n    };\n\n    return $html;\n}\n\nsub html2text ($html, $formatter) {\n\n    my $tree = HTML::TreeBuilder->new();\n    $tree->parse($html);\n    $tree->eof();\n    $tree->elementify();    # just for safety\n\n    my $text = $formatter->format($tree);\n\n    return $text;\n}\n\nmy $left_margin  = 0;\nmy $right_margin = 80;\n\nsub help ($exit_code = 0) {\n    print <<\"EOT\";\nusage: $0 [options] [URL or HTML file]\n\n    -lm  --left=i   : the column of the left margin. (default: $left_margin)\n    -rm  --right=i  : the column of the right margin. (default: $right_margin)\nEOT\n\n    exit($exit_code);\n}\n\nGetOptions(\n           \"lm|left=i\"  => \\$left_margin,\n           \"rm|right=i\" => \\$right_margin,\n           \"h|help\"     => sub { help(0) }\n          )\n  or do {\n    warn(\"Error in command line arguments\\n\");\n    help(1);\n  };\n\nmy $stdin_on_tty = -t STDIN;\n\nif (not $stdin_on_tty) {    # assume input provided via STDIN\n    ## ok\n}\nelse {\n    @ARGV || do {\n        warn \"\\nerror: no URL or HTML file provided!\\n\\n\";\n        help(2);\n    };\n}\n\nmy $formatter = HTML::FormatText->new(leftmargin  => $left_margin,\n                                      rightmargin => $right_margin,);\n\nmy $html = extract_html($stdin_on_tty ? $ARGV[0] : \\*STDIN);\n$html // die \"error: unable to extract HTML content\";\n\nmy $text = html2text($html, $formatter);\n$text // die \"error: unable to extract text\";\n\nprint $text;\n"
  },
  {
    "path": "Converters/json2csv.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 08 March 2016\n# License: GPLV3\n# Website: https://github.com/trizen\n\n# Converts a stream of newline separated json data to csv format.\n# See also: https://github.com/jehiah/json2csv\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Text::CSV        qw();\nuse JSON             qw(from_json);\nuse Getopt::Std      qw(getopts);\nuse Encode           qw(decode_utf8);\nuse Text::ParseWords qw(quotewords);\n\nuse open IO => ':encoding(UTF-8)', ':std';\n\n@ARGV = map { decode_utf8($_) } @ARGV;\n\nmy %opt;\ngetopts('k:i:o:p:d:', \\%opt);\n\nmy $in  = \\*ARGV;\nmy $out = \\*STDOUT;\n\nif (defined($opt{i})) {\n    open $in, '<', $opt{i}\n      or die \"Can't open file `$opt{i}' for reading: $!\";\n}\n\nif (defined($opt{o})) {\n    open $out, '>', $opt{o}\n      or die \"Can't open file `$opt{o}' for writing: $!\";\n}\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOT\";\nusage: $0 [options] [< input.json] [> output.csv]\n\noptions:\n    -k fields.0,and,nested.fields,to,output\n    -i /path/to/input.json (optional; default is stdin)\n    -o /path/to/output.csv (optional; default is stdout)\n    -d delimiter separator for csv (default: \",\")\n    -p print csv header row\n\nexample:\n    $0 -k user.name,list.0,remote_ip -i input.json -o output.csv\n\nEOT\n    exit($code);\n}\n\n$opt{k} // usage(1);\n\nsub unescape {\n    my ($str) = @_;\n\n    my %esc = (\n               a => \"\\a\",\n               t => \"\\t\",\n               r => \"\\r\",\n               n => \"\\n\",\n               e => \"\\e\",\n               b => \"\\b\",\n               f => \"\\f\",\n              );\n\n    $str =~ s{(?<!\\\\)(?:\\\\\\\\)*\\\\([@{[keys %esc]}])}{$esc{$1}}g;\n    $str;\n}\n\nmy @fields = map { [quotewords(qr/\\./, 0, $_)] } quotewords(qr/\\s*,\\s*/, 1, $opt{k});\n\nsay($opt{p}) if defined($opt{p});\n\nmy $csv = Text::CSV->new(\n                         {\n                          eol      => \"\\n\",\n                          sep_char => defined($opt{d}) ? unescape($opt{d}) : \",\",\n                         }\n                        )\n  or die \"Cannot use CSV: \" . Text::CSV->error_diag();\n\nsub extract {\n    my ($json, $fields) = @_;\n\n    my @row;\n    foreach my $field (@{$fields}) {\n        my $ref = $json;\n\n        foreach my $key (@{$field}) {\n            if (    ref($ref) eq 'ARRAY'\n                and $key =~ /^[-+]?[0-9]+\\z/\n                and exists($ref->[$key])) {\n                $ref = $ref->[$key];\n            }\n            elsif (ref($ref) eq 'HASH'\n                   and exists($ref->{$key})) {\n                $ref = $ref->{$key};\n            }\n            else {\n                local $\" = ' -> ';\n                warn \"[!] Field `$key' (from `@{$field}') does not exists in JSON.\\n\";\n                $ref = undef;\n                last;\n            }\n        }\n\n        push @row, $ref;\n    }\n\n    \\@row;\n}\n\nwhile (defined(my $line = <$in>)) {\n    my $data = extract(from_json($line), \\@fields);\n    $csv->print($out, $data);\n}\n"
  },
  {
    "path": "Converters/markdown2pdf.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 29 July 2022\n# Edit: 05 January 2024\n# https://github.com/trizen\n\n# Markdown to PDF converter, with syntax highlighting.\n\n# Using the following tools:\n#   md2html     -- for converting Markdown to HTML (provided by md4c)\n#   highlight   -- for syntax highlighting\n#   wkhtmltopdf -- for converting HTML to PDF\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse open IO => ':utf8', ':std';\n\nuse HTML::TreeBuilder 5 ('-weak');\nuse HTML::Entities qw(encode_entities);\n\nuse IPC::Run3    qw(run3);\nuse File::Temp   qw(tempfile);\nuse Encode       qw(decode_utf8 encode_utf8);\nuse Getopt::Long qw(GetOptions);\n\nmy $md2html = \"md2html\";    # path to the `md2html` tool\n\nmy $syntax_lang = 'text';\nmy $style       = 'github';\nmy $title       = 'Document';\nmy $page_size   = 'A3';\nmy $mathjax     = 0;            # true to use MathJax.js\nmy $js_delay    = 3000;         # in ms\nmy $keep_html   = 0;\n\nsub usage {\n    my ($exit_code) = @_;\n    $exit_code //= 0;\n\n    print <<\"EOT\";\nusage: $0 [options] [input.md] [output.pdf]\n\noptions:\n\n    --style=s    : style theme for `highlight` (default: $style)\n    --title=s    : title of the PDF file (default: $title)\n    --size=s     : set paper size to: A4, Letter, etc. (default: $page_size)\n    --lang=s     : default syntax highlighting language (default: $syntax_lang)\n    --mathjax!   : enable support for Tex expressions (default: $mathjax)\n    --js-delay=i : JavaScript delay in ms (with --mathjax) (default: $js_delay)\n    --html!      : keep the intermediary HTML file (default: $keep_html)\n\nEOT\n\n    exit($exit_code);\n}\n\nGetOptions(\n           \"lang=s\"     => \\$syntax_lang,\n           \"style=s\"    => \\$style,\n           \"title=s\"    => \\$title,\n           \"size=s\"     => \\$page_size,\n           \"mathjax!\"   => \\$mathjax,\n           \"js-delay=i\" => \\$js_delay,\n           \"html!\"      => \\$keep_html,\n           \"h|help\"     => sub { usage(0) },\n          )\n  or die(\"Error in command line arguments\\n\");\n\nmy $input_markdown_file = $ARGV[0] // usage(2);\nmy $output_pdf_file     = $ARGV[1] // ($input_markdown_file . \".pdf\");\n\nsay \":: Converting Markdown to HTML...\";\nmy $html = `\\Q$md2html\\E --github \\Q$input_markdown_file\\E`;\n\nif ($? != 0) {\n    die \"`$md2html` failed with code: $?\";\n}\n\nmy $tree = HTML::TreeBuilder->new();\n$tree->parse($html);\n$tree->eof();\n\n#my @nodes = $tree->guts();\nmy @nodes = $tree->disembowel();\n\nmy @highlight = qw(highlight --fragment -t 4 --no-trailing-nl -O html --encoding utf-8);\n\nmy ($in_fh,  $tmp_in_file)  = tempfile();\nmy ($out_fh, $tmp_out_file) = tempfile();\n\nmy $html_content = '';\n\nsay \":: Syntax highlighting...\";\n\nforeach my $entry (@nodes) {\n\n    ref($entry) || next;\n\n    my $code = $entry->as_HTML(undef, undef, {});\n\n    if ($entry->tag eq 'pre') {\n\n        my $t = $entry->content->[0];\n\n        if ($t->tag eq 'code') {\n\n            my $lang = $syntax_lang;\n\n            my $class = $t->attr('class');\n            if (defined($class) and $class =~ /^language-(.+)/) {\n                $lang = $1;\n            }\n\n            if ($lang eq 'text' or $lang eq 'none' or $lang eq '') {    # no need to highlight plaintext\n                $html_content .= $code;\n                next;\n            }\n\n            my $content = $t->content() // next;\n\n            if (ref($content) ne 'ARRAY') {\n                warn \":: Unexpected entry: <<$content>>\\n\";\n                next;\n            }\n\n            my $str = join(' ', @{$content});\n            print $in_fh encode_utf8($str);\n            seek($in_fh, 0, 0);\n\n            run3([@highlight, '--syntax', $lang, '--style', $style], $in_fh, $out_fh);\n\n            if ($? != 0) {\n                die \":: Can't execute the `highlight` command!\";\n            }\n\n            $code = \"<pre class=hl>\" . do {\n                seek($out_fh, 0, 0);\n                local $/;\n                decode_utf8(<$out_fh>);\n              }\n              . \"</pre>\";\n\n            seek($in_fh,  0, 0);\n            seek($out_fh, 0, 0);\n\n            truncate($in_fh,  0);\n            truncate($out_fh, 0);\n        }\n    }\n\n    $html_content .= $code;\n}\n\n$title = encode_entities(decode_utf8($title));\n\nmy $final_html = <<\"HTML\";\n<!DOCTYPE html>\n<html>\n<head>\n<meta http-equiv=\"content-type\" content=\"text/html; charset=utf-8\" />\n<title>$title</title>\nHTML\n\nif ($mathjax) {\n\n    # Reference: https://stackoverflow.com/questions/34347818/using-mathjax-on-a-github-page\n    say \":: Adding MathJax support...\";\n    $final_html .= <<'HTML';\n<script type=\"text/javascript\" charset=\"utf-8\"\nsrc=\"https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML,\nhttps://vincenttam.github.io/javascripts/MathJaxLocal.js\"></script>\nHTML\n}\n\nmy $css = `highlight --print-style -O html --style \\Q$style\\E --stdout`;\n\n$final_html .= <<'HTML';\n<style type=\"text/css\">\n/*<![CDATA[*/\n<!--\nHTML\n\n$final_html .= $css;\n\n$final_html .= do {\n    local $/;\n    <DATA>;\n};\n\n$final_html .= <<'HTML';\n-->\n/*]]>*/\n</style>\nHTML\n\n$final_html .= <<'HTML';\n</head>\n<body class=\"markdown-body\">\nHTML\n\n$final_html .= $html_content;\n\n$final_html .= <<'HTML';\n</body>\n</html>\nHTML\n\nmy $tmp_html_file = $output_pdf_file . '.html';\n\ndo {\n    open my $fh, '>:utf8', $tmp_html_file\n      or die \"Can't create file <<$tmp_html_file>>: $!\";\n    print $fh $final_html;\n    close $fh;\n};\n\nsay \":: Converting HTML to PDF...\";\n\nsystem(\n    qw(wkhtmltopdf\n      --quiet\n      --enable-smart-shrinking\n      --images\n      --enable-external-links\n      --enable-local-file-access\n      --load-error-handling ignore),\n    \"--page-size\",\n    $page_size,\n    (\n     $mathjax\n     ? ('--enable-javascript', '--javascript-delay', $js_delay)\n     : ()\n    ),\n    $tmp_html_file,\n    $output_pdf_file,\n);\n\nunlink($tmp_in_file, $tmp_out_file);\nunlink($tmp_html_file) if not $keep_html;\n\nif ($? != 0) {\n    die \"`wkhtmltopdf` failed with code: $?\";\n}\n\nsay \":: Done!\"\n\n__DATA__\n/* theme \"github.css\" from md2pdf */\n\n@font-face {\n  font-family: octicons-anchor;\n  src: url(data:font/woff;charset=utf-8;base64,d09GRgABAAAAAAYcAA0AAAAACjQAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAABGRlRNAAABMAAAABwAAAAca8vGTk9TLzIAAAFMAAAARAAAAFZG1VHVY21hcAAAAZAAAAA+AAABQgAP9AdjdnQgAAAB0AAAAAQAAAAEACICiGdhc3AAAAHUAAAACAAAAAj//wADZ2x5ZgAAAdwAAADRAAABEKyikaNoZWFkAAACsAAAAC0AAAA2AtXoA2hoZWEAAALgAAAAHAAAACQHngNFaG10eAAAAvwAAAAQAAAAEAwAACJsb2NhAAADDAAAAAoAAAAKALIAVG1heHAAAAMYAAAAHwAAACABEAB2bmFtZQAAAzgAAALBAAAFu3I9x/Nwb3N0AAAF/AAAAB0AAAAvaoFvbwAAAAEAAAAAzBdyYwAAAADP2IQvAAAAAM/bz7t4nGNgZGFgnMDAysDB1Ml0hoGBoR9CM75mMGLkYGBgYmBlZsAKAtJcUxgcPsR8iGF2+O/AEMPsznAYKMwIkgMA5REMOXicY2BgYGaAYBkGRgYQsAHyGMF8FgYFIM0ChED+h5j//yEk/3KoSgZGNgYYk4GRCUgwMaACRoZhDwCs7QgGAAAAIgKIAAAAAf//AAJ4nHWMMQrCQBBF/0zWrCCIKUQsTDCL2EXMohYGSSmorScInsRGL2DOYJe0Ntp7BK+gJ1BxF1stZvjz/v8DRghQzEc4kIgKwiAppcA9LtzKLSkdNhKFY3HF4lK69ExKslx7Xa+vPRVS43G98vG1DnkDMIBUgFN0MDXflU8tbaZOUkXUH0+U27RoRpOIyCKjbMCVejwypzJJG4jIwb43rfl6wbwanocrJm9XFYfskuVC5K/TPyczNU7b84CXcbxks1Un6H6tLH9vf2LRnn8Ax7A5WQAAAHicY2BkYGAA4teL1+yI57f5ysDNwgAC529f0kOmWRiYVgEpDgYmEA8AUzEKsQAAAHicY2BkYGB2+O/AEMPCAAJAkpEBFbAAADgKAe0EAAAiAAAAAAQAAAAEAAAAAAAAKgAqACoAiAAAeJxjYGRgYGBhsGFgYgABEMkFhAwM/xn0QAIAD6YBhwB4nI1Ty07cMBS9QwKlQapQW3VXySvEqDCZGbGaHULiIQ1FKgjWMxknMfLEke2A+IJu+wntrt/QbVf9gG75jK577Lg8K1qQPCfnnnt8fX1NRC/pmjrk/zprC+8D7tBy9DHgBXoWfQ44Av8t4Bj4Z8CLtBL9CniJluPXASf0Lm4CXqFX8Q84dOLnMB17N4c7tBo1AS/Qi+hTwBH4rwHHwN8DXqQ30XXAS7QaLwSc0Gn8NuAVWou/gFmnjLrEaEh9GmDdDGgL3B4JsrRPDU2hTOiMSuJUIdKQQayiAth69r6akSSFqIJuA19TrzCIaY8sIoxyrNIrL//pw7A2iMygkX5vDj+G+kuoLdX4GlGK/8Lnlz6/h9MpmoO9rafrz7ILXEHHaAx95s9lsI7AHNMBWEZHULnfAXwG9/ZqdzLI08iuwRloXE8kfhXYAvE23+23DU3t626rbs8/8adv+9DWknsHp3E17oCf+Z48rvEQNZ78paYM38qfk3v/u3l3u3GXN2Dmvmvpf1Srwk3pB/VSsp512bA/GG5i2WJ7wu430yQ5K3nFGiOqgtmSB5pJVSizwaacmUZzZhXLlZTq8qGGFY2YcSkqbth6aW1tRmlaCFs2016m5qn36SbJrqosG4uMV4aP2PHBmB3tjtmgN2izkGQyLWprekbIntJFing32a5rKWCN/SdSoga45EJykyQ7asZvHQ8PTm6cslIpwyeyjbVltNikc2HTR7YKh9LBl9DADC0U/jLcBZDKrMhUBfQBvXRzLtFtjU9eNHKin0x5InTqb8lNpfKv1s1xHzTXRqgKzek/mb7nB8RZTCDhGEX3kK/8Q75AmUM/eLkfA+0Hi908Kx4eNsMgudg5GLdRD7a84npi+YxNr5i5KIbW5izXas7cHXIMAau1OueZhfj+cOcP3P8MNIWLyYOBuxL6DRylJ4cAAAB4nGNgYoAALjDJyIAOWMCiTIxMLDmZedkABtIBygAAAA==) format('woff');\n}\n\n.markdown-body {\n  -ms-text-size-adjust: 100%;\n  -webkit-text-size-adjust: 100%;\n  color: #333;\n  overflow: hidden;\n  font-family: \"Helvetica Neue\", Helvetica, \"Segoe UI\", Arial, freesans, sans-serif;\n  font-size: 16px;\n  line-height: 1.6;\n  word-wrap: break-word;\n  /*padding: 3.17cm 2.54cm 2.54cm 2.54cm;*/\n  padding: 0;\n}\n\n.markdown-body a {\n  background: transparent;\n}\n\n.markdown-body a:active,\n.markdown-body a:hover {\n  outline: 0;\n}\n\n.markdown-body strong {\n  font-weight: bold;\n}\n\n.markdown-body h1 {\n  font-size: 2em;\n  margin: 0.67em 0;\n}\n\n.markdown-body img {\n  border: 0;\n}\n\n.markdown-body hr {\n  -moz-box-sizing: content-box;\n  box-sizing: content-box;\n  height: 0;\n}\n\n.markdown-body pre {\n  overflow: auto;\n}\n\n.markdown-body code,\n.markdown-body kbd,\n.markdown-body pre {\n  font-family: monospace, monospace;\n  font-size: 1em;\n}\n\n.markdown-body input {\n  color: inherit;\n  font: inherit;\n  margin: 0;\n}\n\n.markdown-body html input[disabled] {\n  cursor: default;\n}\n\n.markdown-body input {\n  line-height: normal;\n}\n\n.markdown-body input[type=\"checkbox\"] {\n  -moz-box-sizing: border-box;\n  box-sizing: border-box;\n  padding: 0;\n}\n\n.markdown-body table {\n  border-collapse: collapse;\n  border-spacing: 0;\n}\n\n.markdown-body td,\n.markdown-body th {\n  padding: 0;\n}\n\n.markdown-body * {\n  -moz-box-sizing: border-box;\n  box-sizing: border-box;\n}\n\n.markdown-body input {\n  font: 13px/1.4 Helvetica, arial, freesans, clean, sans-serif, \"Segoe UI Emoji\", \"Segoe UI Symbol\";\n}\n\n.markdown-body a {\n  color: #4183c4;\n  text-decoration: none;\n}\n\n.markdown-body a:hover,\n.markdown-body a:active {\n  text-decoration: underline;\n}\n\n.markdown-body hr {\n  height: 0;\n  margin: 15px 0;\n  overflow: hidden;\n  background: transparent;\n  border: 0;\n  border-bottom: 1px solid #ddd;\n}\n\n.markdown-body hr:before {\n  display: table;\n  content: \"\";\n}\n\n.markdown-body hr:after {\n  display: table;\n  clear: both;\n  content: \"\";\n}\n\n.markdown-body h1,\n.markdown-body h2,\n.markdown-body h3,\n.markdown-body h4,\n.markdown-body h5,\n.markdown-body h6 {\n  margin-top: 15px;\n  margin-bottom: 15px;\n  line-height: 1.1;\n}\n\n.markdown-body h1 {\n  font-size: 30px;\n}\n\n.markdown-body h2 {\n  font-size: 21px;\n}\n\n.markdown-body h3 {\n  font-size: 16px;\n}\n\n.markdown-body h4 {\n  font-size: 14px;\n}\n\n.markdown-body h5 {\n  font-size: 12px;\n}\n\n.markdown-body h6 {\n  font-size: 11px;\n}\n\n.markdown-body blockquote {\n  margin: 0;\n}\n\n.markdown-body ul,\n.markdown-body ol {\n  padding: 0;\n  margin-top: 0;\n  margin-bottom: 0;\n}\n\n.markdown-body ol ol,\n.markdown-body ul ol {\n  list-style-type: lower-roman;\n}\n\n.markdown-body ul ul ol,\n.markdown-body ul ol ol,\n.markdown-body ol ul ol,\n.markdown-body ol ol ol {\n  list-style-type: lower-alpha;\n}\n\n.markdown-body dd {\n  margin-left: 0;\n}\n\n.markdown-body code {\n  font-family: Consolas, \"Liberation Mono\", Menlo, Courier, monospace;\n  font-size: 12px;\n}\n\n.markdown-body pre {\n  margin-top: 0;\n  margin-bottom: 0;\n  font: 12px Consolas, \"Liberation Mono\", Menlo, Courier, monospace;\n}\n\n.markdown-body .octicon {\n  font: normal normal 16px octicons-anchor;\n  line-height: 1;\n  display: inline-block;\n  text-decoration: none;\n  -webkit-font-smoothing: antialiased;\n  -moz-osx-font-smoothing: grayscale;\n  -webkit-user-select: none;\n  -moz-user-select: none;\n  -ms-user-select: none;\n  user-select: none;\n}\n\n.markdown-body .octicon-link:before {\n  content: '\\f05c';\n}\n\n.markdown-body>*:first-child {\n  margin-top: 0 !important;\n}\n\n.markdown-body>*:last-child {\n  margin-bottom: 0 !important;\n}\n\n.markdown-body .anchor {\n  position: absolute;\n  top: 0;\n  left: 0;\n  display: block;\n  padding-right: 6px;\n  padding-left: 30px;\n  margin-left: -30px;\n}\n\n.markdown-body .anchor:focus {\n  outline: none;\n}\n\n.markdown-body h1,\n.markdown-body h2,\n.markdown-body h3,\n.markdown-body h4,\n.markdown-body h5,\n.markdown-body h6 {\n  position: relative;\n  margin-top: 1em;\n  margin-bottom: 16px;\n  font-weight: bold;\n  line-height: 1.4;\n}\n\n.markdown-body h1 .octicon-link,\n.markdown-body h2 .octicon-link,\n.markdown-body h3 .octicon-link,\n.markdown-body h4 .octicon-link,\n.markdown-body h5 .octicon-link,\n.markdown-body h6 .octicon-link {\n  display: none;\n  color: #000;\n  vertical-align: middle;\n}\n\n.markdown-body h1:hover .anchor,\n.markdown-body h2:hover .anchor,\n.markdown-body h3:hover .anchor,\n.markdown-body h4:hover .anchor,\n.markdown-body h5:hover .anchor,\n.markdown-body h6:hover .anchor {\n  padding-left: 8px;\n  margin-left: -30px;\n  text-decoration: none;\n}\n\n.markdown-body h1:hover .anchor .octicon-link,\n.markdown-body h2:hover .anchor .octicon-link,\n.markdown-body h3:hover .anchor .octicon-link,\n.markdown-body h4:hover .anchor .octicon-link,\n.markdown-body h5:hover .anchor .octicon-link,\n.markdown-body h6:hover .anchor .octicon-link {\n  display: inline-block;\n}\n\n.markdown-body h1 {\n  padding-bottom: 0.3em;\n  font-size: 2.25em;\n  line-height: 1.2;\n  border-bottom: 1px solid #eee;\n}\n\n.markdown-body h1 .anchor {\n  line-height: 1;\n}\n\n.markdown-body h2 {\n  padding-bottom: 0.3em;\n  font-size: 1.75em;\n  line-height: 1.225;\n  border-bottom: 1px solid #eee;\n}\n\n.markdown-body h2 .anchor {\n  line-height: 1;\n}\n\n.markdown-body h3 {\n  font-size: 1.5em;\n  line-height: 1.43;\n}\n\n.markdown-body h3 .anchor {\n  line-height: 1.2;\n}\n\n.markdown-body h4 {\n  font-size: 1.25em;\n}\n\n.markdown-body h4 .anchor {\n  line-height: 1.2;\n}\n\n.markdown-body h5 {\n  font-size: 1em;\n}\n\n.markdown-body h5 .anchor {\n  line-height: 1.1;\n}\n\n.markdown-body h6 {\n  font-size: 1em;\n  color: #777;\n}\n\n.markdown-body h6 .anchor {\n  line-height: 1.1;\n}\n\n.markdown-body p,\n.markdown-body blockquote,\n.markdown-body ul,\n.markdown-body ol,\n.markdown-body dl,\n.markdown-body table,\n.markdown-body pre {\n  margin-top: 0;\n  margin-bottom: 16px;\n}\n\n.markdown-body hr {\n  height: 4px;\n  padding: 0;\n  margin: 16px 0;\n  background-color: #e7e7e7;\n  border: 0 none;\n}\n\n.markdown-body ul,\n.markdown-body ol {\n  padding-left: 2em;\n}\n\n.markdown-body ul ul,\n.markdown-body ul ol,\n.markdown-body ol ol,\n.markdown-body ol ul {\n  margin-top: 0;\n  margin-bottom: 0;\n}\n\n.markdown-body li>p {\n  margin-top: 16px;\n}\n\n.markdown-body dl {\n  padding: 0;\n}\n\n.markdown-body dl dt {\n  padding: 0;\n  margin-top: 16px;\n  font-size: 1em;\n  font-style: italic;\n  font-weight: bold;\n}\n\n.markdown-body dl dd {\n  padding: 0 16px;\n  margin-bottom: 16px;\n}\n\n.markdown-body blockquote {\n  padding: 0 15px;\n  color: #777;\n  border-left: 4px solid #ddd;\n}\n\n.markdown-body blockquote>:first-child {\n  margin-top: 0;\n}\n\n.markdown-body blockquote>:last-child {\n  margin-bottom: 0;\n}\n\n.markdown-body table {\n  display: block;\n  width: 100%;\n  overflow: auto;\n  word-break: normal;\n  word-break: keep-all;\n}\n\n.markdown-body table th {\n  font-weight: bold;\n}\n\n.markdown-body table th,\n.markdown-body table td {\n  padding: 6px 13px;\n  border: 1px solid #ddd;\n}\n\n.markdown-body table tr {\n  background-color: #fff;\n  border-top: 1px solid #ccc;\n}\n\n.markdown-body table tr:nth-child(2n) {\n  background-color: #f8f8f8;\n}\n\n.markdown-body img {\n  max-width: 100%;\n  -moz-box-sizing: border-box;\n  box-sizing: border-box;\n}\n\n.markdown-body code {\n  padding: 0;\n  padding-top: 0.2em;\n  padding-bottom: 0.2em;\n  margin: 0;\n  font-size: 85%;\n  background-color: rgba(0,0,0,0.04);\n  border-radius: 3px;\n}\n\n.markdown-body code:before,\n.markdown-body code:after {\n  letter-spacing: -0.2em;\n  content: \"\\00a0\";\n}\n\n.markdown-body pre>code {\n  padding: 0;\n  margin: 0;\n  font-size: 100%;\n  word-break: normal;\n  white-space: pre;\n  background: transparent;\n  border: 0;\n}\n\n.markdown-body .highlight {\n  margin-bottom: 16px;\n}\n\n.markdown-body .highlight pre,\n.markdown-body pre {\n  padding: 16px;\n  overflow: auto;\n  font-size: 85%;\n  line-height: 1.45;\n  background-color: #f7f7f7;\n  border-radius: 3px;\n}\n\n.markdown-body .highlight pre {\n  margin-bottom: 0;\n  word-break: normal;\n}\n\n.markdown-body pre {\n  word-wrap: normal;\n}\n\n.markdown-body pre code {\n  display: inline;\n  max-width: initial;\n  padding: 0;\n  margin: 0;\n  overflow: initial;\n  line-height: inherit;\n  word-wrap: normal;\n  background-color: transparent;\n  border: 0;\n}\n\n.markdown-body pre code:before,\n.markdown-body pre code:after {\n  content: normal;\n}\n\n.markdown-body kbd {\n  display: inline-block;\n  padding: 3px 5px;\n  font-size: 11px;\n  line-height: 10px;\n  color: #555;\n  vertical-align: middle;\n  background-color: #fcfcfc;\n  border: solid 1px #ccc;\n  border-bottom-color: #bbb;\n  border-radius: 3px;\n  box-shadow: inset 0 -1px 0 #bbb;\n}\n\n.markdown-body .pl-c {\n  color: #969896;\n}\n\n.markdown-body .pl-c1,\n.markdown-body .pl-mdh,\n.markdown-body .pl-mm,\n.markdown-body .pl-mp,\n.markdown-body .pl-mr,\n.markdown-body .pl-s1 .pl-v,\n.markdown-body .pl-s3,\n.markdown-body .pl-sc,\n.markdown-body .pl-sv {\n  color: #0086b3;\n}\n\n.markdown-body .pl-e,\n.markdown-body .pl-en {\n  color: #795da3;\n}\n\n.markdown-body .pl-s1 .pl-s2,\n.markdown-body .pl-smi,\n.markdown-body .pl-smp,\n.markdown-body .pl-stj,\n.markdown-body .pl-vo,\n.markdown-body .pl-vpf {\n  color: #333;\n}\n\n.markdown-body .pl-ent {\n  color: #63a35c;\n}\n\n.markdown-body .pl-k,\n.markdown-body .pl-s,\n.markdown-body .pl-st {\n  color: #a71d5d;\n}\n\n.markdown-body .pl-pds,\n.markdown-body .pl-s1,\n.markdown-body .pl-s1 .pl-pse .pl-s2,\n.markdown-body .pl-sr,\n.markdown-body .pl-sr .pl-cce,\n.markdown-body .pl-sr .pl-sra,\n.markdown-body .pl-sr .pl-sre,\n.markdown-body .pl-src {\n  color: #df5000;\n}\n\n.markdown-body .pl-mo,\n.markdown-body .pl-v {\n  color: #1d3e81;\n}\n\n.markdown-body .pl-id {\n  color: #b52a1d;\n}\n\n.markdown-body .pl-ii {\n  background-color: #b52a1d;\n  color: #f8f8f8;\n}\n\n.markdown-body .pl-sr .pl-cce {\n  color: #63a35c;\n  font-weight: bold;\n}\n\n.markdown-body .pl-ml {\n  color: #693a17;\n}\n\n.markdown-body .pl-mh,\n.markdown-body .pl-mh .pl-en,\n.markdown-body .pl-ms {\n  color: #1d3e81;\n  font-weight: bold;\n}\n\n.markdown-body .pl-mq {\n  color: #008080;\n}\n\n.markdown-body .pl-mi {\n  color: #333;\n  font-style: italic;\n}\n\n.markdown-body .pl-mb {\n  color: #333;\n  font-weight: bold;\n}\n\n.markdown-body .pl-md,\n.markdown-body .pl-mdhf {\n  background-color: #ffecec;\n  color: #bd2c00;\n}\n\n.markdown-body .pl-mdht,\n.markdown-body .pl-mi1 {\n  background-color: #eaffea;\n  color: #55a532;\n}\n\n.markdown-body .pl-mdr {\n  color: #795da3;\n  font-weight: bold;\n}\n\n.markdown-body kbd {\n  display: inline-block;\n  padding: 3px 5px;\n  font: 11px Consolas, \"Liberation Mono\", Menlo, Courier, monospace;\n  line-height: 10px;\n  color: #555;\n  vertical-align: middle;\n  background-color: #fcfcfc;\n  border: solid 1px #ccc;\n  border-bottom-color: #bbb;\n  border-radius: 3px;\n  box-shadow: inset 0 -1px 0 #bbb;\n}\n\n.markdown-body .task-list-item {\n  list-style-type: none;\n}\n\n.markdown-body .task-list-item+.task-list-item {\n  margin-top: 3px;\n}\n\n.markdown-body .task-list-item input {\n  float: left;\n  margin: 0.3em 0 0.25em -1.6em;\n  vertical-align: middle;\n}\n\n.markdown-body :checked+.radio-label {\n  z-index: 1;\n  position: relative;\n  border-color: #4183c4;\n}\n\n.footnotes {\n  font-size: 12px;\n}\n\n.nobreak {\n  page-break-inside: avoid;\n}\n"
  },
  {
    "path": "Converters/markdown2pdf_chromium.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 29 July 2022\n# Edit: 05 January 2024\n# https://github.com/trizen\n\n# Markdown to PDF converter, with syntax highlighting.\n\n# Using the following tools:\n#   md2html     -- for converting Markdown to HTML (provided by md4c)\n#   highlight   -- for syntax highlighting\n#   chromium    -- for converting HTML to PDF\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse open IO => ':utf8', ':std';\n\nuse HTML::TreeBuilder 5 ('-weak');\nuse HTML::Entities qw(encode_entities);\n\nuse IPC::Run3    qw(run3);\nuse File::Temp   qw(tempfile);\nuse Encode       qw(decode_utf8 encode_utf8);\nuse Getopt::Long qw(GetOptions);\n\nmy $md2html = \"md2html\";    # path to the `md2html` tool\n\nmy $syntax_lang = 'text';\nmy $style       = 'github';\nmy $title       = 'Document';\nmy $page_size   = 'A4';         # TODO: this is currently unimplemented\nmy $mathjax     = 0;            # true to use MathJax.js\n\nsub usage {\n    my ($exit_code) = @_;\n    $exit_code //= 0;\n\n    print <<\"EOT\";\nusage: $0 [options] [input.md] [output.pdf]\n\noptions:\n\n    --style=s    : style theme for `highlight` (default: $style)\n    --title=s    : title of the PDF file (default: $title)\n    --size=s     : set paper size to: A4, Letter, etc. (default: $page_size)\n    --lang=s     : default syntax highlighting language (default: $syntax_lang)\n    --mathjax!   : enable support for Tex expressions (default: $mathjax)\n\nEOT\n\n    exit($exit_code);\n}\n\nGetOptions(\n           \"lang=s\"   => \\$syntax_lang,\n           \"style=s\"  => \\$style,\n           \"title=s\"  => \\$title,\n           \"size=s\"   => \\$page_size,\n           \"mathjax!\" => \\$mathjax,\n           \"h|help\"   => sub { usage(0) },\n          )\n  or die(\"Error in command line arguments\\n\");\n\nmy $input_markdown_file = $ARGV[0] // usage(2);\nmy $output_pdf_file     = $ARGV[1] // ($input_markdown_file . \".pdf\");\n\nsay \":: Converting Markdown to HTML...\";\nmy $html = `\\Q$md2html\\E --github \\Q$input_markdown_file\\E`;\n\nif ($? != 0) {\n    die \"`$md2html` failed with code: $?\";\n}\n\nmy $tree = HTML::TreeBuilder->new();\n$tree->parse($html);\n$tree->eof();\n\n#my @nodes = $tree->guts();\nmy @nodes = $tree->disembowel();\n\nmy @highlight = qw(highlight --fragment -t 4 --no-trailing-nl -O html --encoding utf-8);\n\nmy ($in_fh,  $tmp_in_file)  = tempfile();\nmy ($out_fh, $tmp_out_file) = tempfile();\n\nmy $html_content = '';\n\nsay \":: Syntax highlighting...\";\n\nforeach my $entry (@nodes) {\n\n    ref($entry) || next;\n\n    my $code = $entry->as_HTML(undef, undef, {});\n\n    if ($entry->tag eq 'pre') {\n\n        my $t = $entry->content->[0];\n\n        if ($t->tag eq 'code') {\n\n            my $lang = $syntax_lang;\n\n            my $class = $t->attr('class');\n            if (defined($class) and $class =~ /^language-(.+)/) {\n                $lang = $1;\n            }\n\n            if ($lang eq 'text' or $lang eq 'none' or $lang eq '') {    # no need to highlight plaintext\n                $html_content .= $code;\n                next;\n            }\n\n            my $content = $t->content() // next;\n\n            if (ref($content) ne 'ARRAY') {\n                warn \":: Unexpected entry: <<$content>>\\n\";\n                next;\n            }\n\n            my $str = join(' ', @{$content});\n            print $in_fh encode_utf8($str);\n            seek($in_fh, 0, 0);\n\n            run3([@highlight, '--syntax', $lang, '--style', $style], $in_fh, $out_fh);\n\n            if ($? != 0) {\n                die \":: Can't execute the `highlight` command!\";\n            }\n\n            $code = \"<pre class=hl>\" . do {\n                seek($out_fh, 0, 0);\n                local $/;\n                decode_utf8(<$out_fh>);\n              }\n              . \"</pre>\";\n\n            seek($in_fh,  0, 0);\n            seek($out_fh, 0, 0);\n\n            truncate($in_fh,  0);\n            truncate($out_fh, 0);\n        }\n    }\n\n    $html_content .= $code;\n}\n\n$title = encode_entities(decode_utf8($title));\n\nmy $final_html = <<\"HTML\";\n<!DOCTYPE html>\n<html>\n<head>\n<meta http-equiv=\"content-type\" content=\"text/html; charset=utf-8\" />\n<title>$title</title>\nHTML\n\nif ($mathjax) {\n\n    # Reference: https://stackoverflow.com/questions/34347818/using-mathjax-on-a-github-page\n    say \":: Adding MathJax support...\";\n    $final_html .= <<'HTML';\n<script type=\"text/javascript\" charset=\"utf-8\"\nsrc=\"https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML,\nhttps://vincenttam.github.io/javascripts/MathJaxLocal.js\"></script>\nHTML\n}\n\nmy $css = `highlight --print-style -O html --style \\Q$style\\E --stdout`;\n\n$final_html .= <<'HTML';\n<style type=\"text/css\">\n/*<![CDATA[*/\n<!--\nHTML\n\n$final_html .= $css;\n\n$final_html .= do {\n    local $/;\n    <DATA>;\n};\n\n$final_html .= <<'HTML';\n-->\n/*]]>*/\n</style>\nHTML\n\n$final_html .= <<'HTML';\n</head>\n<body class=\"markdown-body\">\nHTML\n\n$final_html .= $html_content;\n\n$final_html .= <<'HTML';\n</body>\n</html>\nHTML\n\nmy $tmp_html_file = $output_pdf_file . '.html';\n\ndo {\n    open my $fh, '>:utf8', $tmp_html_file\n      or die \"Can't create file <<$tmp_html_file>>: $!\";\n    print $fh $final_html;\n    close $fh;\n};\n\nsay \":: Converting HTML to PDF...\";\n\n# Reference:\n#   https://peter.sh/experiments/chromium-command-line-switches/\n\nsystem(\n    qw(chromium\n      --headless\n      --disable-gpu\n      --no-pdf-header-footer\n      --disable-pdf-tagging\n      --enable-local-file-accesses\n      --run-all-compositor-stages-before-draw\n      --virtual-time-budget=10000\n    ),\n    \"--print-to-pdf=$output_pdf_file\",\n    $tmp_html_file,\n);\n\nunlink($tmp_in_file, $tmp_out_file, $tmp_html_file);\n\nif ($? != 0) {\n    die \"`chromium` failed with code: $?\";\n}\n\nsay \":: Done!\"\n\n__DATA__\n/* theme \"github.css\" from md2pdf */\n\n@font-face {\n  font-family: octicons-anchor;\n  src: url(data:font/woff;charset=utf-8;base64,d09GRgABAAAAAAYcAA0AAAAACjQAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAABGRlRNAAABMAAAABwAAAAca8vGTk9TLzIAAAFMAAAARAAAAFZG1VHVY21hcAAAAZAAAAA+AAABQgAP9AdjdnQgAAAB0AAAAAQAAAAEACICiGdhc3AAAAHUAAAACAAAAAj//wADZ2x5ZgAAAdwAAADRAAABEKyikaNoZWFkAAACsAAAAC0AAAA2AtXoA2hoZWEAAALgAAAAHAAAACQHngNFaG10eAAAAvwAAAAQAAAAEAwAACJsb2NhAAADDAAAAAoAAAAKALIAVG1heHAAAAMYAAAAHwAAACABEAB2bmFtZQAAAzgAAALBAAAFu3I9x/Nwb3N0AAAF/AAAAB0AAAAvaoFvbwAAAAEAAAAAzBdyYwAAAADP2IQvAAAAAM/bz7t4nGNgZGFgnMDAysDB1Ml0hoGBoR9CM75mMGLkYGBgYmBlZsAKAtJcUxgcPsR8iGF2+O/AEMPsznAYKMwIkgMA5REMOXicY2BgYGaAYBkGRgYQsAHyGMF8FgYFIM0ChED+h5j//yEk/3KoSgZGNgYYk4GRCUgwMaACRoZhDwCs7QgGAAAAIgKIAAAAAf//AAJ4nHWMMQrCQBBF/0zWrCCIKUQsTDCL2EXMohYGSSmorScInsRGL2DOYJe0Ntp7BK+gJ1BxF1stZvjz/v8DRghQzEc4kIgKwiAppcA9LtzKLSkdNhKFY3HF4lK69ExKslx7Xa+vPRVS43G98vG1DnkDMIBUgFN0MDXflU8tbaZOUkXUH0+U27RoRpOIyCKjbMCVejwypzJJG4jIwb43rfl6wbwanocrJm9XFYfskuVC5K/TPyczNU7b84CXcbxks1Un6H6tLH9vf2LRnn8Ax7A5WQAAAHicY2BkYGAA4teL1+yI57f5ysDNwgAC529f0kOmWRiYVgEpDgYmEA8AUzEKsQAAAHicY2BkYGB2+O/AEMPCAAJAkpEBFbAAADgKAe0EAAAiAAAAAAQAAAAEAAAAAAAAKgAqACoAiAAAeJxjYGRgYGBhsGFgYgABEMkFhAwM/xn0QAIAD6YBhwB4nI1Ty07cMBS9QwKlQapQW3VXySvEqDCZGbGaHULiIQ1FKgjWMxknMfLEke2A+IJu+wntrt/QbVf9gG75jK577Lg8K1qQPCfnnnt8fX1NRC/pmjrk/zprC+8D7tBy9DHgBXoWfQ44Av8t4Bj4Z8CLtBL9CniJluPXASf0Lm4CXqFX8Q84dOLnMB17N4c7tBo1AS/Qi+hTwBH4rwHHwN8DXqQ30XXAS7QaLwSc0Gn8NuAVWou/gFmnjLrEaEh9GmDdDGgL3B4JsrRPDU2hTOiMSuJUIdKQQayiAth69r6akSSFqIJuA19TrzCIaY8sIoxyrNIrL//pw7A2iMygkX5vDj+G+kuoLdX4GlGK/8Lnlz6/h9MpmoO9rafrz7ILXEHHaAx95s9lsI7AHNMBWEZHULnfAXwG9/ZqdzLI08iuwRloXE8kfhXYAvE23+23DU3t626rbs8/8adv+9DWknsHp3E17oCf+Z48rvEQNZ78paYM38qfk3v/u3l3u3GXN2Dmvmvpf1Srwk3pB/VSsp512bA/GG5i2WJ7wu430yQ5K3nFGiOqgtmSB5pJVSizwaacmUZzZhXLlZTq8qGGFY2YcSkqbth6aW1tRmlaCFs2016m5qn36SbJrqosG4uMV4aP2PHBmB3tjtmgN2izkGQyLWprekbIntJFing32a5rKWCN/SdSoga45EJykyQ7asZvHQ8PTm6cslIpwyeyjbVltNikc2HTR7YKh9LBl9DADC0U/jLcBZDKrMhUBfQBvXRzLtFtjU9eNHKin0x5InTqb8lNpfKv1s1xHzTXRqgKzek/mb7nB8RZTCDhGEX3kK/8Q75AmUM/eLkfA+0Hi908Kx4eNsMgudg5GLdRD7a84npi+YxNr5i5KIbW5izXas7cHXIMAau1OueZhfj+cOcP3P8MNIWLyYOBuxL6DRylJ4cAAAB4nGNgYoAALjDJyIAOWMCiTIxMLDmZedkABtIBygAAAA==) format('woff');\n}\n\n.markdown-body {\n  -ms-text-size-adjust: 100%;\n  -webkit-text-size-adjust: 100%;\n  color: #333;\n  overflow: hidden;\n  font-family: \"Helvetica Neue\", Helvetica, \"Segoe UI\", Arial, freesans, sans-serif;\n  font-size: 16px;\n  line-height: 1.6;\n  word-wrap: break-word;\n  /*padding: 3.17cm 2.54cm 2.54cm 2.54cm;*/\n  padding: 0;\n}\n\n.markdown-body a {\n  background: transparent;\n}\n\n.markdown-body a:active,\n.markdown-body a:hover {\n  outline: 0;\n}\n\n.markdown-body strong {\n  font-weight: bold;\n}\n\n.markdown-body h1 {\n  font-size: 2em;\n  margin: 0.67em 0;\n}\n\n.markdown-body img {\n  border: 0;\n}\n\n.markdown-body hr {\n  -moz-box-sizing: content-box;\n  box-sizing: content-box;\n  height: 0;\n}\n\n.markdown-body pre {\n  overflow: auto;\n}\n\n.markdown-body code,\n.markdown-body kbd,\n.markdown-body pre {\n  font-family: monospace, monospace;\n  font-size: 1em;\n}\n\n.markdown-body input {\n  color: inherit;\n  font: inherit;\n  margin: 0;\n}\n\n.markdown-body html input[disabled] {\n  cursor: default;\n}\n\n.markdown-body input {\n  line-height: normal;\n}\n\n.markdown-body input[type=\"checkbox\"] {\n  -moz-box-sizing: border-box;\n  box-sizing: border-box;\n  padding: 0;\n}\n\n.markdown-body table {\n  border-collapse: collapse;\n  border-spacing: 0;\n}\n\n.markdown-body td,\n.markdown-body th {\n  padding: 0;\n}\n\n.markdown-body * {\n  -moz-box-sizing: border-box;\n  box-sizing: border-box;\n}\n\n.markdown-body input {\n  font: 13px/1.4 Helvetica, arial, freesans, clean, sans-serif, \"Segoe UI Emoji\", \"Segoe UI Symbol\";\n}\n\n.markdown-body a {\n  color: #4183c4;\n  text-decoration: none;\n}\n\n.markdown-body a:hover,\n.markdown-body a:active {\n  text-decoration: underline;\n}\n\n.markdown-body hr {\n  height: 0;\n  margin: 15px 0;\n  overflow: hidden;\n  background: transparent;\n  border: 0;\n  border-bottom: 1px solid #ddd;\n}\n\n.markdown-body hr:before {\n  display: table;\n  content: \"\";\n}\n\n.markdown-body hr:after {\n  display: table;\n  clear: both;\n  content: \"\";\n}\n\n.markdown-body h1,\n.markdown-body h2,\n.markdown-body h3,\n.markdown-body h4,\n.markdown-body h5,\n.markdown-body h6 {\n  margin-top: 15px;\n  margin-bottom: 15px;\n  line-height: 1.1;\n}\n\n.markdown-body h1 {\n  font-size: 30px;\n}\n\n.markdown-body h2 {\n  font-size: 21px;\n}\n\n.markdown-body h3 {\n  font-size: 16px;\n}\n\n.markdown-body h4 {\n  font-size: 14px;\n}\n\n.markdown-body h5 {\n  font-size: 12px;\n}\n\n.markdown-body h6 {\n  font-size: 11px;\n}\n\n.markdown-body blockquote {\n  margin: 0;\n}\n\n.markdown-body ul,\n.markdown-body ol {\n  padding: 0;\n  margin-top: 0;\n  margin-bottom: 0;\n}\n\n.markdown-body ol ol,\n.markdown-body ul ol {\n  list-style-type: lower-roman;\n}\n\n.markdown-body ul ul ol,\n.markdown-body ul ol ol,\n.markdown-body ol ul ol,\n.markdown-body ol ol ol {\n  list-style-type: lower-alpha;\n}\n\n.markdown-body dd {\n  margin-left: 0;\n}\n\n.markdown-body code {\n  font-family: Consolas, \"Liberation Mono\", Menlo, Courier, monospace;\n  font-size: 12px;\n}\n\n.markdown-body pre {\n  margin-top: 0;\n  margin-bottom: 0;\n  font: 12px Consolas, \"Liberation Mono\", Menlo, Courier, monospace;\n}\n\n.markdown-body .octicon {\n  font: normal normal 16px octicons-anchor;\n  line-height: 1;\n  display: inline-block;\n  text-decoration: none;\n  -webkit-font-smoothing: antialiased;\n  -moz-osx-font-smoothing: grayscale;\n  -webkit-user-select: none;\n  -moz-user-select: none;\n  -ms-user-select: none;\n  user-select: none;\n}\n\n.markdown-body .octicon-link:before {\n  content: '\\f05c';\n}\n\n.markdown-body>*:first-child {\n  margin-top: 0 !important;\n}\n\n.markdown-body>*:last-child {\n  margin-bottom: 0 !important;\n}\n\n.markdown-body .anchor {\n  position: absolute;\n  top: 0;\n  left: 0;\n  display: block;\n  padding-right: 6px;\n  padding-left: 30px;\n  margin-left: -30px;\n}\n\n.markdown-body .anchor:focus {\n  outline: none;\n}\n\n.markdown-body h1,\n.markdown-body h2,\n.markdown-body h3,\n.markdown-body h4,\n.markdown-body h5,\n.markdown-body h6 {\n  position: relative;\n  margin-top: 1em;\n  margin-bottom: 16px;\n  font-weight: bold;\n  line-height: 1.4;\n}\n\n.markdown-body h1 .octicon-link,\n.markdown-body h2 .octicon-link,\n.markdown-body h3 .octicon-link,\n.markdown-body h4 .octicon-link,\n.markdown-body h5 .octicon-link,\n.markdown-body h6 .octicon-link {\n  display: none;\n  color: #000;\n  vertical-align: middle;\n}\n\n.markdown-body h1:hover .anchor,\n.markdown-body h2:hover .anchor,\n.markdown-body h3:hover .anchor,\n.markdown-body h4:hover .anchor,\n.markdown-body h5:hover .anchor,\n.markdown-body h6:hover .anchor {\n  padding-left: 8px;\n  margin-left: -30px;\n  text-decoration: none;\n}\n\n.markdown-body h1:hover .anchor .octicon-link,\n.markdown-body h2:hover .anchor .octicon-link,\n.markdown-body h3:hover .anchor .octicon-link,\n.markdown-body h4:hover .anchor .octicon-link,\n.markdown-body h5:hover .anchor .octicon-link,\n.markdown-body h6:hover .anchor .octicon-link {\n  display: inline-block;\n}\n\n.markdown-body h1 {\n  padding-bottom: 0.3em;\n  font-size: 2.25em;\n  line-height: 1.2;\n  border-bottom: 1px solid #eee;\n}\n\n.markdown-body h1 .anchor {\n  line-height: 1;\n}\n\n.markdown-body h2 {\n  padding-bottom: 0.3em;\n  font-size: 1.75em;\n  line-height: 1.225;\n  border-bottom: 1px solid #eee;\n}\n\n.markdown-body h2 .anchor {\n  line-height: 1;\n}\n\n.markdown-body h3 {\n  font-size: 1.5em;\n  line-height: 1.43;\n}\n\n.markdown-body h3 .anchor {\n  line-height: 1.2;\n}\n\n.markdown-body h4 {\n  font-size: 1.25em;\n}\n\n.markdown-body h4 .anchor {\n  line-height: 1.2;\n}\n\n.markdown-body h5 {\n  font-size: 1em;\n}\n\n.markdown-body h5 .anchor {\n  line-height: 1.1;\n}\n\n.markdown-body h6 {\n  font-size: 1em;\n  color: #777;\n}\n\n.markdown-body h6 .anchor {\n  line-height: 1.1;\n}\n\n.markdown-body p,\n.markdown-body blockquote,\n.markdown-body ul,\n.markdown-body ol,\n.markdown-body dl,\n.markdown-body table,\n.markdown-body pre {\n  margin-top: 0;\n  margin-bottom: 16px;\n}\n\n.markdown-body hr {\n  height: 4px;\n  padding: 0;\n  margin: 16px 0;\n  background-color: #e7e7e7;\n  border: 0 none;\n}\n\n.markdown-body ul,\n.markdown-body ol {\n  padding-left: 2em;\n}\n\n.markdown-body ul ul,\n.markdown-body ul ol,\n.markdown-body ol ol,\n.markdown-body ol ul {\n  margin-top: 0;\n  margin-bottom: 0;\n}\n\n.markdown-body li>p {\n  margin-top: 16px;\n}\n\n.markdown-body dl {\n  padding: 0;\n}\n\n.markdown-body dl dt {\n  padding: 0;\n  margin-top: 16px;\n  font-size: 1em;\n  font-style: italic;\n  font-weight: bold;\n}\n\n.markdown-body dl dd {\n  padding: 0 16px;\n  margin-bottom: 16px;\n}\n\n.markdown-body blockquote {\n  padding: 0 15px;\n  color: #777;\n  border-left: 4px solid #ddd;\n}\n\n.markdown-body blockquote>:first-child {\n  margin-top: 0;\n}\n\n.markdown-body blockquote>:last-child {\n  margin-bottom: 0;\n}\n\n.markdown-body table {\n  display: block;\n  width: 100%;\n  overflow: auto;\n  word-break: normal;\n  word-break: keep-all;\n}\n\n.markdown-body table th {\n  font-weight: bold;\n}\n\n.markdown-body table th,\n.markdown-body table td {\n  padding: 6px 13px;\n  border: 1px solid #ddd;\n}\n\n.markdown-body table tr {\n  background-color: #fff;\n  border-top: 1px solid #ccc;\n}\n\n.markdown-body table tr:nth-child(2n) {\n  background-color: #f8f8f8;\n}\n\n.markdown-body img {\n  max-width: 100%;\n  -moz-box-sizing: border-box;\n  box-sizing: border-box;\n}\n\n.markdown-body code {\n  padding: 0;\n  padding-top: 0.2em;\n  padding-bottom: 0.2em;\n  margin: 0;\n  font-size: 85%;\n  background-color: rgba(0,0,0,0.04);\n  border-radius: 3px;\n}\n\n.markdown-body code:before,\n.markdown-body code:after {\n  letter-spacing: -0.2em;\n  content: \"\\00a0\";\n}\n\n.markdown-body pre>code {\n  padding: 0;\n  margin: 0;\n  font-size: 100%;\n  word-break: normal;\n  white-space: pre;\n  background: transparent;\n  border: 0;\n}\n\n.markdown-body .highlight {\n  margin-bottom: 16px;\n}\n\n.markdown-body .highlight pre,\n.markdown-body pre {\n  padding: 16px;\n  overflow: auto;\n  font-size: 85%;\n  line-height: 1.45;\n  background-color: #f7f7f7;\n  border-radius: 3px;\n}\n\n.markdown-body .highlight pre {\n  margin-bottom: 0;\n  word-break: normal;\n}\n\n.markdown-body pre {\n  word-wrap: normal;\n}\n\n.markdown-body pre code {\n  display: inline;\n  max-width: initial;\n  padding: 0;\n  margin: 0;\n  overflow: initial;\n  line-height: inherit;\n  word-wrap: normal;\n  background-color: transparent;\n  border: 0;\n}\n\n.markdown-body pre code:before,\n.markdown-body pre code:after {\n  content: normal;\n}\n\n.markdown-body kbd {\n  display: inline-block;\n  padding: 3px 5px;\n  font-size: 11px;\n  line-height: 10px;\n  color: #555;\n  vertical-align: middle;\n  background-color: #fcfcfc;\n  border: solid 1px #ccc;\n  border-bottom-color: #bbb;\n  border-radius: 3px;\n  box-shadow: inset 0 -1px 0 #bbb;\n}\n\n.markdown-body .pl-c {\n  color: #969896;\n}\n\n.markdown-body .pl-c1,\n.markdown-body .pl-mdh,\n.markdown-body .pl-mm,\n.markdown-body .pl-mp,\n.markdown-body .pl-mr,\n.markdown-body .pl-s1 .pl-v,\n.markdown-body .pl-s3,\n.markdown-body .pl-sc,\n.markdown-body .pl-sv {\n  color: #0086b3;\n}\n\n.markdown-body .pl-e,\n.markdown-body .pl-en {\n  color: #795da3;\n}\n\n.markdown-body .pl-s1 .pl-s2,\n.markdown-body .pl-smi,\n.markdown-body .pl-smp,\n.markdown-body .pl-stj,\n.markdown-body .pl-vo,\n.markdown-body .pl-vpf {\n  color: #333;\n}\n\n.markdown-body .pl-ent {\n  color: #63a35c;\n}\n\n.markdown-body .pl-k,\n.markdown-body .pl-s,\n.markdown-body .pl-st {\n  color: #a71d5d;\n}\n\n.markdown-body .pl-pds,\n.markdown-body .pl-s1,\n.markdown-body .pl-s1 .pl-pse .pl-s2,\n.markdown-body .pl-sr,\n.markdown-body .pl-sr .pl-cce,\n.markdown-body .pl-sr .pl-sra,\n.markdown-body .pl-sr .pl-sre,\n.markdown-body .pl-src {\n  color: #df5000;\n}\n\n.markdown-body .pl-mo,\n.markdown-body .pl-v {\n  color: #1d3e81;\n}\n\n.markdown-body .pl-id {\n  color: #b52a1d;\n}\n\n.markdown-body .pl-ii {\n  background-color: #b52a1d;\n  color: #f8f8f8;\n}\n\n.markdown-body .pl-sr .pl-cce {\n  color: #63a35c;\n  font-weight: bold;\n}\n\n.markdown-body .pl-ml {\n  color: #693a17;\n}\n\n.markdown-body .pl-mh,\n.markdown-body .pl-mh .pl-en,\n.markdown-body .pl-ms {\n  color: #1d3e81;\n  font-weight: bold;\n}\n\n.markdown-body .pl-mq {\n  color: #008080;\n}\n\n.markdown-body .pl-mi {\n  color: #333;\n  font-style: italic;\n}\n\n.markdown-body .pl-mb {\n  color: #333;\n  font-weight: bold;\n}\n\n.markdown-body .pl-md,\n.markdown-body .pl-mdhf {\n  background-color: #ffecec;\n  color: #bd2c00;\n}\n\n.markdown-body .pl-mdht,\n.markdown-body .pl-mi1 {\n  background-color: #eaffea;\n  color: #55a532;\n}\n\n.markdown-body .pl-mdr {\n  color: #795da3;\n  font-weight: bold;\n}\n\n.markdown-body kbd {\n  display: inline-block;\n  padding: 3px 5px;\n  font: 11px Consolas, \"Liberation Mono\", Menlo, Courier, monospace;\n  line-height: 10px;\n  color: #555;\n  vertical-align: middle;\n  background-color: #fcfcfc;\n  border: solid 1px #ccc;\n  border-bottom-color: #bbb;\n  border-radius: 3px;\n  box-shadow: inset 0 -1px 0 #bbb;\n}\n\n.markdown-body .task-list-item {\n  list-style-type: none;\n}\n\n.markdown-body .task-list-item+.task-list-item {\n  margin-top: 3px;\n}\n\n.markdown-body .task-list-item input {\n  float: left;\n  margin: 0.3em 0 0.25em -1.6em;\n  vertical-align: middle;\n}\n\n.markdown-body :checked+.radio-label {\n  z-index: 1;\n  position: relative;\n  border-color: #4183c4;\n}\n\n.footnotes {\n  font-size: 12px;\n}\n\n.nobreak {\n  page-break-inside: avoid;\n}\n"
  },
  {
    "path": "Converters/markdown2text.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 19 November 2023\n# https://github.com/trizen\n\n# Convert Markdown to text (UTF-8).\n\n# # Using the following tool:\n#   md2html -- for converting Markdown to HTML (provided by md4c)\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse HTML::TreeBuilder 5 qw(-weak);\nuse HTML::FormatText    qw();\nuse Getopt::Long        qw(GetOptions);\nuse File::Temp          qw(tempfile);\nuse Encode              qw(encode_utf8 decode_utf8);\n\nbinmode(STDIN,  ':utf8');\nbinmode(STDOUT, ':utf8');\n\nmy $md2html = \"md2html\";    # path to the `md2html` tool\n\nsub read_input ($source) {\n\n    if (ref($source) eq 'GLOB') {\n        my $content = do {\n            local $/;\n            <$source>;\n        };\n        return $content;\n    }\n\n    my $content = do {\n        open my $fh, '<:utf8', $source\n          or die \"Can't open file <<$source>> for reading: $!\";\n        local $/;\n        <$fh>;\n    };\n\n    return $content;\n}\n\nsub html2text ($html, $formatter) {\n\n    my $tree = HTML::TreeBuilder->new();\n    $tree->parse($html);\n    $tree->eof();\n    $tree->elementify();    # just for safety\n\n    my $text = $formatter->format($tree);\n\n    return $text;\n}\n\nmy $left_margin  = 0;\nmy $right_margin = 80;\n\nsub usage ($exit_code = 0) {\n    print <<\"EOT\";\nusage: $0 [options] [input.md]\n\n    -lm  --left=i   : the column of the left margin. (default: $left_margin)\n    -rm  --right=i  : the column of the right margin. (default: $right_margin)\nEOT\n\n    exit($exit_code);\n}\n\nGetOptions(\n           \"lm|left=i\"  => \\$left_margin,\n           \"rm|right=i\" => \\$right_margin,\n           \"h|help\"     => sub { usage(0) },\n          )\n  or do {\n    warn(\"Error in command line arguments\\n\");\n    usage(1);\n  };\n\nmy $stdin_on_tty = -t STDIN;\n\nif (not $stdin_on_tty) {    # assume input provided via STDIN\n    ## ok\n}\nelse {\n    @ARGV || do {\n        warn \"\\nerror: no input file provided!\\n\\n\";\n        usage(2);\n    };\n}\n\nmy $formatter = HTML::FormatText->new(leftmargin  => $left_margin,\n                                      rightmargin => $right_margin,);\n\nmy $markdown = read_input($stdin_on_tty ? $ARGV[0] : \\*STDIN);\n$markdown // die \"error: unable to read Markdown content\";\n\nmy ($md_fh, $md_file) = tempfile();\nprint $md_fh encode_utf8($markdown);\nclose $md_fh;\n\nmy $html = decode_utf8(scalar `\\Q$md2html\\E --github \\Q$md_file\\E`);\n\nunlink($md_file);\n\nmy $text = html2text($html, $formatter);\n$text // die \"error: unable to extract text\";\n\nprint $text;\n"
  },
  {
    "path": "Converters/notepadfree_to_txt.pl",
    "content": "#!/usr/bin/perl\n\n# Convert Android Notepad Free backup notes to text files.\n\nuse utf8;\nuse 5.014;\nuse autodie;\nuse warnings;\n\nuse JSON                  qw(from_json);\nuse File::Slurper         qw(read_text write_text);\nuse File::Spec::Functions qw(catfile updir);\nuse File::Compare         qw();\n\nmy $output_dir = 'Text files';\nmy $meta_json  = from_json(read_text('notes_meta_data.json'));\n\nif (not -d $output_dir) {\n    mkdir($output_dir);\n}\n\nOUTER: foreach my $note (@{$meta_json->{notes}}) {\n\n    my $title        = $note->{title};\n    my $file         = $note->{file};\n    my $lastEditDate = $note->{lastEditDate};\n\n    $title =~ s{/}{÷}g;    # replace '/' with '÷'\n\n    my $input_file  = catfile(updir, $file);\n    my $content     = read_text($input_file);\n    my $output_file = catfile($output_dir, $title . '.txt');\n\n    for (my $k = 1 ; (-f $output_file) ; ++$k) {\n        if (File::Compare::compare($input_file, $output_file) == 0) {\n            say \"File `$output_file` already exists... Skipping...\";\n            next OUTER;    # files are equal\n        }\n        else {\n            $output_file = catfile($output_dir, $title . '_' . $k . '.txt');\n        }\n    }\n\n    say \"Creating: `$output_file`...\";\n    write_text($output_file, $content);\n    utime($lastEditDate, $lastEditDate, $output_file);\n}\n"
  },
  {
    "path": "Converters/pod2pdf.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 16 April 2023\n# https://github.com/trizen\n\n# POD to PDF converter, with syntax highlighting.\n\n# Using the following tools:\n#   pod2markdown    -- for converting POD to Markdown (part of Pod::Markdown)\n#   markdown2pdf.pl -- for converting Markdown to PDF\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Getopt::Long qw(GetOptions);\nuse File::Temp   qw(tempfile);\n\nmy $markdown2pdf = \"markdown2pdf.pl\";    # path to the `markdown2pdf.pl` script\nmy $pod2markdown = \"pod2markdown\";       # path to the `pod2markdown` script\n\nmy $lang      = 'perl';\nmy $style     = 'github';\nmy $title     = 'Document';\nmy $page_size = 'A3';\nmy $mathjax   = 0;                       # true to use MathJax\n\nsub usage {\n    my ($exit_code) = @_;\n    $exit_code //= 0;\n\n    print <<\"EOT\";\nusage: $0 [options] [input.pod] [output.pdf]\n\noptions:\n\n    --lang=s    : default syntax highlighting language (default: $lang)\n    --style=s   : style theme for `highlight` (default: $style)\n    --title=s   : title of the PDF file (default: $title)\n    --size=s    : set paper size to: A4, Letter, etc. (default: $page_size)\n    --mathjax!  : enable support for Tex expressions (default: $mathjax)\n\nEOT\n\n    exit($exit_code);\n}\n\nGetOptions(\n           \"lang=s\"   => \\$lang,\n           \"title=s\"  => \\$title,\n           \"size=s\"   => \\$page_size,\n           \"mathjax!\" => \\$mathjax,\n           \"h|help\"   => sub { usage(0) },\n          )\n  or die(\"Error in command line arguments\\n\");\n\nmy $input_pod_file  = $ARGV[0] // usage(2);\nmy $output_pdf_file = $ARGV[1] // \"output.pdf\";\n\nsay \":: Converting POD to Markdown...\";\n\nmy $md = `\\Q$pod2markdown\\E \\Q$input_pod_file\\E`;\n\nif (!defined($md)) {\n    die \"Failed to convert POD to Markdown...\\n\";\n}\n\nmy ($md_fh, $md_file) = tempfile();\nprint $md_fh $md;\nclose $md_fh;\n\nsay \":: Converting Markdown to PDF...\";\nsystem($markdown2pdf, ($mathjax ? \"--mathjax\" : ()), \"--lang\", $lang, \"--style\", $style, \"--title\", $title, \"--size\", $page_size, $md_file, $output_pdf_file);\n\nif ($? != 0) {\n    die \"Failed to convert Markdown to PDF...\\n\";\n}\n\nunlink($md_file);\n"
  },
  {
    "path": "Converters/pod2text.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 19 November 2023\n# https://github.com/trizen\n\n# Convert POD to text (UTF-8).\n\n# Using the following tools:\n#   pod2markdown    -- for converting POD to Markdown (part of Pod::Markdown)\n#   md2hml          -- for converting Markdown to HTML (provided by md4c)\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse HTML::TreeBuilder 5 qw(-weak);\nuse HTML::FormatText    qw();\nuse Getopt::Long        qw(GetOptions);\nuse File::Temp          qw(tempfile);\nuse Encode              qw(encode_utf8 decode_utf8);\n\nbinmode(STDIN,  ':utf8');\nbinmode(STDOUT, ':utf8');\n\nmy $pod2markdown = \"pod2markdown\";    # path to the `pod2markdown` script\nmy $md2html      = \"md2html\";         # path to the `md2html` tool\n\nsub read_input ($source) {\n\n    if (ref($source) eq 'GLOB') {\n        my $content = do {\n            local $/;\n            <$source>;\n        };\n        return $content;\n    }\n\n    my $content = do {\n        open my $fh, '<:utf8', $source\n          or die \"Can't open file <<$source>> for reading: $!\";\n        local $/;\n        <$fh>;\n    };\n\n    return $content;\n}\n\nsub html2text ($html, $formatter) {\n\n    my $tree = HTML::TreeBuilder->new();\n    $tree->parse($html);\n    $tree->eof();\n    $tree->elementify();    # just for safety\n\n    my $text = $formatter->format($tree);\n\n    return $text;\n}\n\nmy $left_margin  = 0;\nmy $right_margin = 80;\n\nsub usage ($exit_code = 0) {\n    print <<\"EOT\";\nusage: $0 [options] [input.pod]\n\n    -lm  --left=i   : the column of the left margin. (default: $left_margin)\n    -rm  --right=i  : the column of the right margin. (default: $right_margin)\nEOT\n\n    exit($exit_code);\n}\n\nGetOptions(\n           \"lm|left=i\"  => \\$left_margin,\n           \"rm|right=i\" => \\$right_margin,\n           \"h|help\"     => sub { usage(0) },\n          )\n  or do {\n    warn(\"Error in command line arguments\\n\");\n    usage(1);\n  };\n\nmy $stdin_on_tty = -t STDIN;\n\nif (not $stdin_on_tty) {    # assume input provided via STDIN\n    ## ok\n}\nelse {\n    @ARGV || do {\n        warn \"\\nerror: no input file provided!\\n\\n\";\n        usage(2);\n    };\n}\n\nmy $formatter = HTML::FormatText->new(leftmargin  => $left_margin,\n                                      rightmargin => $right_margin,);\n\nmy $pod = read_input($stdin_on_tty ? $ARGV[0] : \\*STDIN);\n\nmy ($pod_fh, $pod_file) = tempfile();\nprint $pod_fh encode_utf8($pod);\nclose $pod_fh;\n\nmy $md = `\\Q$pod2markdown\\E \\Q$pod_file\\E`;\n\nunlink($pod_file);\n\nif (!defined($md)) {\n    die \"Failed to convert POD to Markdown...\\n\";\n}\n\nmy ($md_fh, $md_file) = tempfile();\nprint $md_fh $md;\nclose $md_fh;\n\nmy $html = decode_utf8(scalar `\\Q$md2html\\E --github \\Q$md_file\\E`);\n\nunlink($md_file);\n\nmy $text = html2text($html, $formatter);\n$text // die \"error: unable to extract text\";\n\nprint $text;\n"
  },
  {
    "path": "Converters/recompress.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 04 June 2024\n# https://github.com/trizen\n\n# Recompress gzip, zip, bzip2, zstd, xz, lzma, lzip, lzf or lzop to another format.\n\nuse 5.036;\nuse Getopt::Long                  qw(GetOptions);\nuse IO::Uncompress::AnyUncompress qw();\n\nuse constant {\n              CHUNK_SIZE => 1 << 16,    # how many bytes to read per chunk\n             };\n\nmy %compressors = (\n    'gzip' => {\n               class  => 'IO::Compress::Gzip',\n               format => 'gz',\n              },\n\n    'bzip2' => {\n                class  => 'IO::Compress::Bzip2',\n                format => 'bz2',\n               },\n\n    'lzf' => {\n              class  => 'IO::Compress::Lzf',\n              format => 'lzf',\n             },\n\n    #~ 'lzip' => {  # buggy\n    #~ class => 'IO::Compress::Lzip',\n    #~ format => 'lz',\n    #~ },\n\n    #~ 'lzma' => {  # buggy\n    #~ class => 'IO::Compress::Lzma',\n    #~ format => 'lzma',\n    #~ },\n\n    'lzop' => {\n               class  => 'IO::Compress::Lzop',\n               format => 'lzop',\n              },\n\n    'xz' => {\n             class  => 'IO::Compress::Xz',\n             format => 'xz',\n            },\n\n    'zstd' => {\n               class  => 'IO::Compress::Zstd',\n               format => 'zst',\n              },\n\n    'zip' => {\n              class  => 'IO::Compress::Zip',\n              format => 'zip',\n             },\n);\n\nmy $compression_method = 'none';\nmy $keep_original      = 0;\nmy $overwrite          = 0;\n\nsub usage ($exit_code) {\n\n    local $\" = \", \";\n\n    print <<\"EOT\";\nusage: $0 [options] [.gz files]\n\noptions:\n\n    -c --compress=s     : select compression method\n                          valid: @{[sort keys %compressors]}\n    -k --keep!          : keep the original files (default: $keep_original)\n    -f --force!         : overwrite existing files (default: $overwrite)\n    -h --help           : print this message and exit\n\nexample:\n\n    # Convert a bunch of Gzip files to XZ format\n    $0 -c=xz *.gz\nEOT\n\n    exit($exit_code);\n}\n\nGetOptions(\n           'c|compress=s' => \\$compression_method,\n           'k|keep!'      => \\$keep_original,\n           'f|force!'     => \\$overwrite,\n           'h|help'       => sub { usage(0) },\n          )\n  or usage(1);\n\n@ARGV || usage(2);\n\nmy $compression = $compressors{$compression_method} // do {\n    warn \"[!] Please select a valid compression method with `-c` option!\\n\";\n    warn \"[!] Valid values: \", join(', ', sort keys(%compressors)), \"\\n\";\n    exit(1);\n};\n\nforeach my $file (@ARGV) {\n\n    if (not -f $file) {\n        warn \":: Not a file: <<$file>>. Skipping...\\n\";\n        next;\n    }\n\n    say \"\\n:: Processing: $file\";\n\n    my $new_file   = $file;\n    my $new_format = $compression->{format};\n\n    if (   $new_file =~ s{\\.t\\w+\\z}{.t$new_format}i\n        or $new_file =~ s{\\.\\w+\\z}{.$new_format}i) {\n        ## ok\n    }\n    else {\n        $new_file .= \".$new_format\";\n    }\n\n    if (-e $new_file) {\n        if (not $overwrite) {\n            say \"-> File <<$new_file>> already exists. Skipping...\";\n            next;\n        }\n    }\n\n    my $in_fh = IO::Uncompress::AnyUncompress->new($file) or do {\n        warn \"[!] Probably not a valid compressed file ($IO::Uncompress::AnyUncompress::AnyUncompressError). Skipping...\\n\";\n        next;\n    };\n\n    require(($compression->{class} =~ s{::}{/}rg) . '.pm');\n\n    my $out_fh = $compression->{class}->new($new_file)\n      or die \"[!] Failed to initialize the compressor class: $compression->{class}: $!\\n\";\n\n    while (read($in_fh, (my $chunk), CHUNK_SIZE)) {\n        $out_fh->write($chunk);\n    }\n\n    ($in_fh->eof and $in_fh->close and $out_fh->close) || do {\n        warn \"[!] Something went wrong! Skipping...\\n\";\n        unlink($new_file);\n        next;\n    };\n\n    my $old_size = -s $file;\n    my $new_size = -s $new_file;\n\n    say \"-> $old_size vs. $new_size\";\n\n    if (not $keep_original) {\n        say \"-> Removing the original file: $file\";\n        unlink($file) or warn \"[!] Can't remove file <<$file>>: $!\\n\";\n    }\n}\n"
  },
  {
    "path": "Converters/unicode2ascii.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 29 April 2012\n# Edit: 12 March 2023\n# https://github.com/trizen\n\n# Substitute Unicode characters with ASCII characters in a stream input.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Encode          qw(decode_utf8);\nuse Text::Unidecode qw(unidecode);\n\nwhile (defined(my $line = <>)) {\n    print unidecode(decode_utf8($line));\n}\n"
  },
  {
    "path": "Converters/vnt2txt_simple.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 08 May 2013\n# https://github.com/trizen\n\n# Convert a .vnt file to a plain text file and set the right modification time.\n\nuse strict;\nuse warnings;\n\nuse Date::Parse;\nuse File::Slurper qw(read_text write_text);\n\nmy $source = shift() // die \"usage: $0 [vnt file]\\n\";\n\nread_text($source) =~ /^BODY.*?:(.*?)\\R^DCREATED:(\\S+)\\R^LAST-MODIFIED:(\\S+)/ms;\n\nwrite_text((my $tfile =\n      join('-', unpack(\"A4A2A2\", $2))   .\n'.' . join(\".\", unpack(\"x9A2A2A2\", $2)) . '.txt'), $1);\n\nutime time(), str2time($3), $tfile, $source;\n"
  },
  {
    "path": "Converters/xml2hash.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 27 December 2013\n# Edit: 01 January 2018\n# License: GPLv3\n# https://github.com/trizen\n\n# A tiny pure-Perl XML parser.\n\nuse utf8;\nuse 5.010;\nuse strict;\nuse warnings;\n\n{\n    my %entities = (\n                    'amp'  => '&',\n                    'quot' => '\"',\n                    'apos' => \"'\",\n                    'gt'   => '>',\n                    'lt'   => '<',\n                   );\n\n    state $ent_re = do {\n        local $\" = '|';\n        qr/&(@{[keys %entities]});/;\n    };\n\n    sub _decode_entities {\n        $_[0] =~ s/$ent_re/$entities{$1}/gor;\n    }\n}\n\nsub xml2hash {\n    my $xml     = shift(@_) // '';\n    my $xml_ref = {};\n\n    $xml = \"$xml\";\n\n    my %args = (\n                attr  => '-',\n                text  => '#text',\n                empty => q{},\n                @_\n               );\n\n    my %ctags;\n    my $ref = $xml_ref;\n    state $inv_chars = q{!\"#$@%&'()*+,/;\\\\<=>?\\]\\[^`{|}~};\n    state $valid_tag = qr{[^\\-.\\s0-9$inv_chars][^$inv_chars\\s]*};\n\n    {\n        if (\n            $xml =~ m{\\G< \\s*\n                        ($valid_tag)  \\s*\n                        ((?>$valid_tag\\s*=\\s*(?>\".*?\"|'.*?')|\\s+)+)? \\s*\n                        (/)?\\s*> \\s*\n                    }gcsxo\n          ) {\n\n            my ($tag, $attrs, $closed) = ($1, $2, $3);\n\n            if (defined $attrs) {\n                push @{$ctags{$tag}}, $ref;\n\n                $ref =\n                    ref $ref eq 'HASH'\n                  ? ref $ref->{$tag}\n                      ? $ref->{$tag}\n                      : (\n                         defined $ref->{$tag}\n                         ? ($ref->{$tag} = [$ref->{$tag}])\n                         : ($ref->{$tag} //= [])\n                        )\n                  : ref $ref eq 'ARRAY' ? ref $ref->[-1]{$tag}\n                      ? $ref->[-1]{$tag}\n                      : (\n                         defined $ref->[-1]{$tag}\n                         ? ($ref->[-1]{$tag} = [$ref->[-1]{$tag}])\n                         : ($ref->[-1]{$tag} //= [])\n                        )\n                  : [];\n\n                ++$#{$ref} if ref $ref eq 'ARRAY';\n\n                while (\n                    $attrs =~ m{\\G\n                        ($valid_tag) \\s*=\\s*\n                        (?>\n                            \"(.*?)\"\n                                    |\n                            '(.*?)'\n                        ) \\s*\n                        }gsxo\n                  ) {\n                    my ($key, $value) = ($1, $+);\n                    $key = join(q{}, $args{attr}, $key);\n                    if (ref $ref eq 'ARRAY') {\n                        $ref->[-1]{$key} = _decode_entities($value);\n                    }\n                    elsif (ref $ref eq 'HASH') {\n                        $ref->{$key} = $value;\n                    }\n                }\n\n                if (defined $closed) {\n                    $ref = pop @{$ctags{$tag}};\n                }\n\n                if ($xml =~ m{\\G<\\s*/\\s*\\Q$tag\\E\\s*>\\s*}gc) {\n                    $ref = pop @{$ctags{$tag}};\n                }\n                elsif ($xml =~ m{\\G([^<]+)(?=<)}gsc) {\n                    if (ref $ref eq 'ARRAY') {\n                        $ref->[-1]{$args{text}} .= _decode_entities($1);\n                        $ref = pop @{$ctags{$tag}};\n                    }\n                    elsif (ref $ref eq 'HASH') {\n                        $ref->{$args{text}} .= $1;\n                        $ref = pop @{$ctags{$tag}};\n                    }\n                }\n            }\n            elsif (defined $closed) {\n                if (ref $ref eq 'ARRAY') {\n                    if (exists $ref->[-1]{$tag}) {\n                        if (ref $ref->[-1]{$tag} ne 'ARRAY') {\n                            $ref->[-1]{$tag} = [$ref->[-1]{$tag}];\n                        }\n                        push @{$ref->[-1]{$tag}}, $args{empty};\n                    }\n                    else {\n                        $ref->[-1]{$tag} = $args{empty};\n                    }\n                }\n            }\n            else {\n                if ($xml =~ /\\G(?=<(?!!))/) {\n                    push @{$ctags{$tag}}, $ref;\n\n                    $ref =\n                        ref $ref eq 'HASH'\n                      ? ref $ref->{$tag}\n                          ? $ref->{$tag}\n                          : (\n                             defined $ref->{$tag}\n                             ? ($ref->{$tag} = [$ref->{$tag}])\n                             : ($ref->{$tag} //= [])\n                            )\n                      : ref $ref eq 'ARRAY' ? ref $ref->[-1]{$tag}\n                          ? $ref->[-1]{$tag}\n                          : (\n                             defined $ref->[-1]{$tag}\n                             ? ($ref->[-1]{$tag} = [$ref->[-1]{$tag}])\n                             : ($ref->[-1]{$tag} //= [])\n                            )\n                      : [];\n\n                    ++$#{$ref} if ref $ref eq 'ARRAY';\n                    redo;\n                }\n                elsif ($xml =~ /\\G<!\\[CDATA\\[(.*?)\\]\\]>\\s*/gcs or $xml =~ /\\G([^<]+)(?=<)/gsc) {\n                    my ($text) = $1;\n\n                    if ($xml =~ m{\\G<\\s*/\\s*\\Q$tag\\E\\s*>\\s*}gc) {\n                        if (ref $ref eq 'ARRAY') {\n                            if (exists $ref->[-1]{$tag}) {\n                                if (ref $ref->[-1]{$tag} ne 'ARRAY') {\n                                    $ref->[-1]{$tag} = [$ref->[-1]{$tag}];\n                                }\n                                push @{$ref->[-1]{$tag}}, $text;\n                            }\n                            else {\n                                $ref->[-1]{$tag} .= _decode_entities($text);\n                            }\n                        }\n                        elsif (ref $ref eq 'HASH') {\n                            $ref->{$tag} .= $text;\n                        }\n                    }\n                    else {\n                        push @{$ctags{$tag}}, $ref;\n\n                        $ref =\n                            ref $ref eq 'HASH'\n                          ? ref $ref->{$tag}\n                              ? $ref->{$tag}\n                              : (\n                                 defined $ref->{$tag}\n                                 ? ($ref->{$tag} = [$ref->{$tag}])\n                                 : ($ref->{$tag} //= [])\n                                )\n                          : ref $ref eq 'ARRAY' ? ref $ref->[-1]{$tag}\n                              ? $ref->[-1]{$tag}\n                              : (\n                                 defined $ref->[-1]{$tag}\n                                 ? ($ref->[-1]{$tag} = [$ref->[-1]{$tag}])\n                                 : ($ref->[-1]{$tag} //= [])\n                                )\n                          : [];\n\n                        ++$#{$ref} if ref $ref eq 'ARRAY';\n\n                        if (ref $ref eq 'ARRAY') {\n                            if (exists $ref->[-1]{$tag}) {\n                                if (ref $ref->[-1]{$tag} ne 'ARRAY') {\n                                    $ref->[-1] = [$ref->[-1]{$tag}];\n                                }\n                                push @{$ref->[-1]}, {$args{text} => $text};\n                            }\n                            else {\n                                $ref->[-1]{$args{text}} .= $text;\n                            }\n                        }\n                        elsif (ref $ref eq 'HASH') {\n                            $ref->{$tag} .= $text;\n                        }\n                    }\n                }\n            }\n\n            if ($xml =~ m{\\G<\\s*/\\s*\\Q$tag\\E\\s*>\\s*}gc) {\n                ## tag closed - ok\n            }\n\n            redo;\n        }\n        elsif ($xml =~ m{\\G<\\s*/\\s*($valid_tag)\\s*>\\s*}gco) {\n            if (exists $ctags{$1} and @{$ctags{$1}}) {\n                $ref = pop @{$ctags{$1}};\n            }\n            redo;\n        }\n        elsif ($xml =~ /\\G<!\\[CDATA\\[(.*?)\\]\\]>\\s*/gcs or $xml =~ m{\\G([^<]+)(?=<)}gsc) {\n            if (ref $ref eq 'ARRAY') {\n                $ref->[-1]{$args{text}} .= $1;\n            }\n            elsif (ref $ref eq 'HASH') {\n                $ref->{$args{text}} .= $1;\n            }\n            redo;\n        }\n        elsif ($xml =~ /\\G<\\?/gc) {\n            $xml =~ /\\G.*?\\?>\\s*/gcs or die \"Invalid XML!\";\n            redo;\n        }\n        elsif ($xml =~ /\\G<!--/gc) {\n            $xml =~ /\\G.*?-->\\s*/gcs or die \"Comment not closed!\";\n            redo;\n        }\n        elsif ($xml =~ /\\G<!DOCTYPE\\s+/gc) {\n            $xml =~ /\\G(?>$valid_tag|\\s+|\".*?\"|'.*?')*\\[.*?\\]>\\s*/sgco\n              or $xml =~ /\\G.*?>\\s*/sgc\n              or die \"DOCTYPE not closed!\";\n            redo;\n        }\n        elsif ($xml =~ /\\G\\z/gc) {\n            ## ok\n        }\n        elsif ($xml =~ /\\G\\s+/gc) {\n            redo;\n        }\n        else {\n            die \"Syntax error near: --> \", [split(/\\n/, substr($xml, pos($xml), 2**6))]->[0], \" <--\\n\";\n        }\n    }\n\n    return $xml_ref;\n}\n\n#\n## Usage: $hash = xml2hash($xml)\n#\n\nuse Data::Dump qw(pp);\n\npp xml2hash(\n            do { local $/; <DATA> }\n           );\n\n__DATA__\n<?xml version=\"1.0\"?>\n<?xml-stylesheet href=\"catalog.xsl\" type=\"text/xsl\"?>\n<!DOCTYPE catalog SYSTEM \"catalog.dtd\">\n<catalog>\n   <product description=\"Cardigan Sweater\" product_image=\"cardigan.jpg\">\n      <catalog_item gender=\"Men's\">\n         <item_number>QWZ5671</item_number>\n         <price>39.95</price>\n         <size description=\"Medium\">\n            <color_swatch image=\"red_cardigan.jpg\">Red</color_swatch>\n            <color_swatch image=\"burgundy_cardigan.jpg\">Burgundy</color_swatch>\n         </size>\n         <size description=\"Large\">\n            <color_swatch image=\"red_cardigan.jpg\">Red</color_swatch>\n            <color_swatch image=\"burgundy_cardigan.jpg\">Burgundy</color_swatch>\n         </size>\n      </catalog_item>\n      <catalog_item gender=\"Women's\">\n         <item_number>RRX9856</item_number>\n         <price>42.50</price>\n         <size description=\"Small\">\n            <color_swatch image=\"red_cardigan.jpg\">Red</color_swatch>\n            <color_swatch image=\"navy_cardigan.jpg\">Navy</color_swatch>\n            <color_swatch image=\"burgundy_cardigan.jpg\">Burgundy</color_swatch>\n         </size>\n         <size description=\"Medium\">\n            <color_swatch image=\"red_cardigan.jpg\">Red</color_swatch>\n            <color_swatch image=\"navy_cardigan.jpg\">Navy</color_swatch>\n            <color_swatch image=\"burgundy_cardigan.jpg\">Burgundy</color_swatch>\n            <color_swatch image=\"black_cardigan.jpg\">Black</color_swatch>\n         </size>\n         <size description=\"Large\">\n            <color_swatch image=\"navy_cardigan.jpg\">Navy</color_swatch>\n            <color_swatch image=\"black_cardigan.jpg\">Black</color_swatch>\n         </size>\n         <size description=\"Extra Large\">\n            <color_swatch image=\"burgundy_cardigan.jpg\">Burgundy</color_swatch>\n            <color_swatch image=\"black_cardigan.jpg\">Black</color_swatch>\n         </size>\n      </catalog_item>\n   </product>\n</catalog>\n"
  },
  {
    "path": "Converters/xpm_c_to_perl.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date : 21 February 2013\n# https://github.com/trizen\n\n# XPM to Perl data.\n# for file in `find /usr/share/pixmaps/ -maxdepth 1`; do perl -X xpm_c_to_perl.pl $file > $(basename $file); done\n\nuse strict;\nuse Data::Dump qw(dump);\n$Data::Dump::INDENT = '';\n\nsub parse_xpm_file {\n    my ($file) = @_;\n\n    open my $fh, '<', $file\n      or die \"Can't open file '$file': $!\";\n\n    my @data;\n    while (<$fh>) {\n        if (/^\"(.*?)\",?\\s*(\\};\\s*)?$/s) {\n            push @data, $1;\n        }\n        else {\n            #print STDERR $_;\n        }\n    }\n\n    close $fh;\n    my $dumped = dump \\@data;\n\n    # In list context returns the dumped data and the array itself.\n    # In scalar context returns only the dumped data\n    return wantarray ? ($dumped, \\@data) : $dumped;\n}\n\nmy $xpm_file = shift // die \"usage: $0 [xpm_file]\\n\";\n$xpm_file =~ /\\.xpm\\z/i or die \"Not a XPM file: $xpm_file\\n\";\nmy $data = parse_xpm_file($xpm_file);\nprint $data;\n"
  },
  {
    "path": "Converters/xz2gz.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 04 June 2024\n# https://github.com/trizen\n\n# Convert XZ files to Gzip format.\n\nuse 5.036;\nuse IO::Compress::Gzip   qw();\nuse IO::Uncompress::UnXz qw();\nuse Getopt::Long         qw(GetOptions);\n\nuse constant {\n              CHUNK_SIZE => 1 << 16,    # how many bytes to read per chunk\n             };\n\nsub xz2gz ($in_fh, $out_fh) {\n\n    while ($in_fh->read(my $chunk, CHUNK_SIZE)) {\n        $out_fh->print($chunk);\n    }\n\n    $in_fh->eof   or return;\n    $in_fh->close or return;\n    $out_fh->close;\n}\n\nmy $keep_original = 0;\nmy $overwrite     = 0;\n\nsub usage ($exit_code) {\n    print <<\"EOT\";\nusage: $0 [options] [.gz files]\n\noptions:\n\n    -k --keep!          : keep the original XZ files (default: $keep_original)\n    -f --force!         : overwrite existing files (default: $overwrite)\n    -h --help           : print this message and exit\n\nexample:\n\n    # Convert a bunch of XZ files to Gzip format\n    $0 *.xz\nEOT\n\n    exit($exit_code);\n}\n\nGetOptions(\n           'k|keep!'  => \\$keep_original,\n           'f|force!' => \\$overwrite,\n           'h|help'   => sub { usage(0) },\n          )\n  or usage(1);\n\n@ARGV || usage(2);\n\nforeach my $xz_file (@ARGV) {\n\n    if (not -f $xz_file) {\n        warn \":: Not a file: <<$xz_file>>. Skipping...\\n\";\n        next;\n    }\n\n    say \"\\n:: Processing: $xz_file\";\n\n    my $gz_file = $xz_file;\n\n    if (   $gz_file =~ s{\\.txz\\z}{.tgz}i\n        or $gz_file =~ s{\\.xz\\z}{.gz}i) {\n        ## ok\n    }\n    else {\n        $gz_file .= '.gz';\n    }\n\n    if (-e $gz_file) {\n        if (not $overwrite) {\n            say \"-> File <<$gz_file>> already exists. Skipping...\";\n            next;\n        }\n    }\n\n    my $in_fh = IO::Uncompress::UnXz->new($xz_file) or do {\n        warn \"[!] Probably not an XZ file ($IO::Uncompress::UnXz::UnXzError). Skipping...\\n\";\n        next;\n    };\n\n    my $out_fh = IO::Compress::Gzip->new($gz_file)\n      or die \"[!] Failed to initialize the compressor: $IO::Compress::Gzip::GzipError\\n\";\n\n    xz2gz($in_fh, $out_fh) || do {\n        warn \"[!] Something went wrong! Skipping...\\n\";\n        unlink($gz_file);\n        next;\n    };\n\n    my $old_size = -s $xz_file;\n    my $new_size = -s $gz_file;\n\n    say \"-> $old_size vs. $new_size\";\n\n    if (not $keep_original) {\n        say \"-> Removing the original XZ file: $xz_file\";\n        unlink($xz_file) or warn \"[!] Can't remove file <<$xz_file>>: $!\\n\";\n    }\n}\n"
  },
  {
    "path": "Converters/zip2tar.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 10 April 2024\n# https://github.com/trizen\n\n# Convert a ZIP archive to a TAR archive (with optional compression).\n\n# Limitation: the TAR file is created in-memory!\n\nuse 5.036;\n\nuse Archive::Tar;\nuse Archive::Tar::Constant;\nuse Archive::Zip qw(:ERROR_CODES :CONSTANTS);\nuse Getopt::Long qw(GetOptions);\nuse Encode       qw(encode_utf8);\n\nsub zip2tar ($zip_file) {\n\n    my $zip = Archive::Zip->new();\n\n    unless ($zip->read($zip_file) == AZ_OK) {\n        warn \"Probably not a ZIP file: <<$zip_file>>. Skipping...\\n\";\n        return undef;\n    }\n\n    my $tar = Archive::Tar->new;\n\n    foreach my $member ($zip->members) {\n\n        if (ref($member) eq 'Archive::Zip::DirectoryMember') {\n            my $dirName = encode_utf8($member->fileName);\n            $tar->add_data(\n                           $dirName, '',\n                           {\n                            name  => $dirName,\n                            size  => 0,\n                            mode  => 0755,\n                            mtime => $member->lastModTime,\n                            type  => Archive::Tar::Constant::DIR,\n                           }\n                          );\n        }\n        elsif (ref($member) eq 'Archive::Zip::ZipFileMember') {\n\n            if ($member->isEncrypted) {\n                warn \"[!] This archive is encrypted! Skipping...\\n\";\n                return undef;\n            }\n\n            my $fileName = encode_utf8($member->fileName);\n            my $size     = $member->uncompressedSize;\n\n            $member->desiredCompressionMethod(COMPRESSION_STORED);\n            $member->rewindData() == AZ_OK or die \"error in rewindData()\";\n\n            my ($bufferRef, $status) = $member->readChunk($size);\n            die \"error $status\" if ($status != AZ_OK and $status != AZ_STREAM_END);\n            $member->endRead();\n\n            my $read_size = length($$bufferRef);\n\n            if ($size != $read_size) {\n                die \"Error reading member <<$fileName>>: ($size (expected) != $read_size (actual value))\";\n            }\n\n            $tar->add_data(\n                           $fileName,\n                           $$bufferRef,\n                           {\n                            name  => $fileName,\n                            size  => $size,\n                            mode  => 0644,\n                            mtime => $member->lastModTime,\n                            type  => Archive::Tar::Constant::FILE,\n                           }\n                          );\n        }\n        else {\n            die \"Unknown member of type: \", ref($member);\n        }\n    }\n\n    return $tar;\n}\n\nmy $compression_method = 'none';\nmy $keep_original      = 0;\nmy $overwrite          = 0;\n\nsub usage ($exit_code) {\n    print <<\"EOT\";\nusage: $0 [options] [zip files]\n\noptions:\n\n    -c --compress=s     : compression method (default: $compression_method)\n                          valid: none, gz, bz2, xz\n    -k --keep!          : keep the original ZIP files (default: $keep_original)\n    -f --force!         : overwrite existing files (default: $overwrite)\n    -h --help           : print this message and exit\n\nexample:\n\n    # Convert a bunch of zip files to tar.gz\n    $0 -c=gz *.zip\nEOT\n\n    exit($exit_code);\n}\n\nGetOptions(\n           'c|compress=s' => \\$compression_method,\n           'k|keep!'      => \\$keep_original,\n           'f|force!'     => \\$overwrite,\n           'h|help'       => sub { usage(0) },\n          )\n  or usage(1);\n\n@ARGV || usage(2);\n\nmy $tar_suffix       = '';\nmy $compression_flag = undef;\n\nif ($compression_method eq 'none') {\n    ## ok\n}\nelsif ($compression_method eq 'gz') {\n    $tar_suffix .= '.gz';\n    $compression_flag = Archive::Tar::Constant::COMPRESS_GZIP;\n}\nelsif ($compression_method eq 'bz2') {\n    $tar_suffix .= '.bz2';\n    $compression_flag = Archive::Tar::Constant::COMPRESS_BZIP;\n    Archive::Tar->has_bzip2_support or die \"Please install: IO::Compress::Bzip2\\n\";\n}\nelsif ($compression_method eq 'xz') {\n    $tar_suffix       = '.xz';\n    $compression_flag = Archive::Tar::Constant::COMPRESS_XZ;\n    Archive::Tar->has_xz_support or die \"Please install: IO::Compress::Xz\\n\";\n}\nelse {\n    die \"Unknown compression method: <<$compression_method>>\\n\";\n}\n\nforeach my $zip_file (@ARGV) {\n    if (-f $zip_file) {\n\n        say \"\\n:: Processing: $zip_file\";\n        my $tar_file = ($zip_file =~ s{\\.zip\\z}{}ri) . '.tar' . $tar_suffix;\n\n        if (-e $tar_file) {\n            if (not $overwrite) {\n                say \"-> Tar file <<$tar_file>> already exists. Skipping...\";\n                next;\n            }\n        }\n\n        my $tar = zip2tar($zip_file) // next;\n\n        say \"-> Creating TAR file: $tar_file\";\n        $tar->write($tar_file, (defined($compression_flag) ? $compression_flag : ()));\n\n        my $old_size = -s $zip_file;\n        my $new_size = -s $tar_file;\n\n        say \"-> $old_size vs. $new_size\";\n\n        if (not $keep_original) {\n            say \"-> Removing the original ZIP file: $zip_file\";\n            unlink($zip_file) or warn \"[!] Can't remove file <<$zip_file>>: $!\\n\";\n        }\n    }\n    else {\n        warn \":: Not a file: <<$zip_file>>. Skipping...\\n\";\n    }\n}\n"
  },
  {
    "path": "Converters/zip2tar_fast.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 10 April 2024\n# https://github.com/trizen\n\n# Convert a ZIP archive to a TAR archive (with optional compression).\n\n# Using `zip2tarcat` from LittleUtils:\n#   https://sourceforge.net/projects/littleutils/\n\n# Converts and recompresses a ZIP file, without storing the entire archive in memory.\n\nuse 5.036;\nuse Getopt::Long qw(GetOptions);\n\nuse constant {\n              CHUNK_SIZE => 1 << 16,    # how many bytes to read per chunk\n             };\n\nmy $zip2tarcat_cmd = 'zip2tarcat';    # command to zip2tarcat\n\nsub zip2tar ($zip_file, $out_fh) {\n\n    open(my $fh, '-|:raw', $zip2tarcat_cmd, $zip_file)\n      or die \"Cannot pipe into <<$zip2tarcat_cmd>>: $!\";\n\n    while (read($fh, (my $chunk), CHUNK_SIZE)) {\n        $out_fh->print($chunk);\n    }\n\n    $out_fh->close;\n    close $fh;\n}\n\nmy $compression_method = 'none';\nmy $keep_original      = 0;\nmy $overwrite          = 0;\n\nsub usage ($exit_code) {\n    print <<\"EOT\";\nusage: $0 [options] [zip files]\n\noptions:\n\n    -c --compress=s     : compression method (default: $compression_method)\n                          valid: none, xz, gz, bz2, lzo, lzip, zstd\n    -k --keep!          : keep the original ZIP files (default: $keep_original)\n    -f --force!         : overwrite existing files (default: $overwrite)\n    -h --help           : print this message and exit\n\nexample:\n\n    # Convert a bunch of zip files to tar.xz\n    $0 -c=xz *.zip\nEOT\n\n    exit($exit_code);\n}\n\nGetOptions(\n           'c|compress=s' => \\$compression_method,\n           'k|keep!'      => \\$keep_original,\n           'f|force!'     => \\$overwrite,\n           'h|help'       => sub { usage(0) },\n          )\n  or usage(1);\n\n@ARGV || usage(2);\n\nmy $tar_suffix        = '';\nmy $compression_class = undef;\n\nif ($compression_method eq 'none') {\n    require IO::Handle;\n}\nelsif ($compression_method =~ /^(?:gz|gzip)\\z/) {\n    require IO::Compress::Gzip;\n    $tar_suffix .= '.gz';\n    $compression_class = 'IO::Compress::Gzip';\n}\nelsif ($compression_method =~ /^(?:bz2|bzip2)\\z/) {\n    require IO::Compress::Bzip2;\n    $tar_suffix .= '.bz2';\n    $compression_class = 'IO::Compress::Bzip2';\n}\nelsif ($compression_method =~ /^(?:xz)\\z/) {\n    require IO::Compress::Xz;\n    $tar_suffix        = '.xz';\n    $compression_class = 'IO::Compress::Xz';\n}\nelsif ($compression_method =~ /^(?:lzo|lzop)\\z/) {\n    require IO::Compress::Lzop;\n    $tar_suffix        = '.lzo';\n    $compression_class = 'IO::Compress::Lzop';\n}\nelsif ($compression_method =~ /^(?:lz|lzip)\\z/) {\n    require IO::Compress::Lzip;\n    $tar_suffix        = '.lz';\n    $compression_class = 'IO::Compress::Lzip';\n}\nelsif ($compression_method =~ /^(?:zstandard|zstd?)\\z/) {\n    require IO::Compress::Zstd;\n    $tar_suffix        = '.zst';\n    $compression_class = 'IO::Compress::Zstd';\n}\nelse {\n    die \"Unknown compression method: <<$compression_method>>\\n\";\n}\n\nforeach my $zip_file (@ARGV) {\n    if (-f $zip_file) {\n\n        say \"\\n:: Processing: $zip_file\";\n        my $tar_file = ($zip_file =~ s{\\.zip\\z}{}ri) . '.tar' . $tar_suffix;\n\n        if (-e $tar_file) {\n            if (not $overwrite) {\n                say \"-> Tar file <<$tar_file>> already exists. Skipping...\";\n                next;\n            }\n        }\n\n        my $out_fh;\n        if (defined($compression_class)) {\n            $out_fh = $compression_class->new($tar_file)\n              or do {\n                warn \"[!] Failed to initialize the compressor: $!. Skipping...\\n\";\n                next;\n              };\n        }\n        else {\n            open $out_fh, '>:raw', $tar_file\n              or do {\n                warn \"[!] Can't create tar file <<$tar_file>>: $!\\n\";\n                next;\n              };\n        }\n\n        zip2tar($zip_file, $out_fh) || do {\n            warn \"[!] Something went wrong! Skipping...\\n\";\n            unlink($tar_file);\n            next;\n        };\n\n        my $old_size = -s $zip_file;\n        my $new_size = -s $tar_file;\n\n        say \"-> $old_size vs. $new_size\";\n\n        if (not $keep_original) {\n            say \"-> Removing the original ZIP file: $zip_file\";\n            unlink($zip_file) or warn \"[!] Can't remove file <<$zip_file>>: $!\\n\";\n        }\n    }\n    else {\n        warn \":: Not a file: <<$zip_file>>. Skipping...\\n\";\n    }\n}\n"
  },
  {
    "path": "Decoders/base64_decoding-tutorial.pl",
    "content": "#!/usr/bin/perl\n\n# How does base64 works?\n# This short tutorial explains the basics behind the base64 decoding\n# Written by Trizen under the GPL.\n#\n# See also: https://en.wikipedia.org/wiki/Uuencoding\n#           https://en.wikipedia.org/wiki/Base64\n\nmy $base64 = 'SnVzdCBhbm90aGVyIFBlcmwgaGFja2VyLAo=';    # base64\n\n#--------------Removing non-base64 chars--------------#\n\n# Anything that *ISN'T* A-Z, a-z, 0-9 or [+/._=] will be removed\n$base64 =~ tr|A-Za-z0-9+=/||cd;                        # remove non-base64 chars\n$base64 =~ s/=+$//;                                    # remove padding (if any)\n\n#--------------Transliteration--------------#\n$base64 =~ tr{A-Za-z0-9+/}{ -_};                     # convert to uuencoded format\n\n# same thing as:\n# $base64 =~ tr{ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/}\n#              { !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\\\]^_};\n# so: A => ' '\n#     B => '!'\n#     C => '\"'\n#     and so on...\n\n#--------------Decoding--------------#\nprint unpack 'u', pack('C', 32 + int(length($1) * 3 / 4)) . $1 while $base64 =~ s/(.{60}|.+)//;\n\n# For short strings, this works just fine:\n#     print unpack('u','M'. $base64);\n\n# unpack('u','...') unpacks this:\n#       print unpack('u', ':2G5S=\"!A;F]T:&5R(%!E<FP@:&%C:V5R+ H');\n\n# Compact code 1 (with substitution)\n# Code from https://en.wikipedia.org/wiki/Uuencoding\nsub base64_decode_1 {\n    my ($base64) = @_;\n    $base64 =~ tr|A-Za-z0-9+=/||cd;    # remove non-base64 chars\n    $base64 =~ s/=+$//;                # remove padding\n    $base64 =~ tr|A-Za-z0-9+/| -_|;    # convert to uuencoded format\n\n    my $decoded;\n    $decoded .= unpack 'u', pack('C', 32 + int(length($1) * 3 / 4)) . $1 while $base64 =~ s/(.{60}|.+)//;\n    return $decoded;\n}\n\n# Without substitution\n# Coded by Trizen\nsub base64_decode_2 {\n    my ($base64) = @_;\n    $base64 =~ tr|A-Za-z0-9+=/||cd;    # remove non-base64 chars\n    $base64 =~ s/=+$//;                # remove padding\n    $base64 =~ tr|A-Za-z0-9+/| -_|;    # convert to uuencoded format\n\n    my $x = 84;                        # block size (default should be 60?)\n    my $i = -$x;\n\n    my $decoded;\n    while (my $block = unpack(\"A$x\", $base64)) {\n        my ($base64_length, $offset) = (length($base64), $i + $x);\n        substr($base64, $base64_length > $offset ? $offset : $base64_length, $base64_length > $x ? $x : $base64_length, '');\n        $decoded .= chr(32 + int(length($block) * 3 / 4)) . $block;\n    }\n    return unpack('u', $decoded);\n}\n\n# May be memory expensive, but it's faster than base64_decode_2()\n# Coded by Trizen\nsub base64_decode_3 {\n    my ($base64) = @_;\n\n    $base64 =~ tr|A-Za-z0-9+=/||cd;    # remove non-base64 chars\n    $base64 =~ s/=+$//;                # remove padding\n    $base64 =~ tr|A-Za-z0-9+/| -_|;    # convert to uuencoded format\n\n    my $x = 84;                        # block size (default should be 60?)\n\n    my $decoded;\n    foreach my $block (unpack(\"(A$x)*\", $base64)) {\n        $decoded .= chr(32 + int(length($block) * 3 / 4)) . $block;\n    }\n\n    return unpack('u', $decoded);\n}\n\n# Faster still :)\n# Coded by Gisle Aas\n# https://metacpan.org/release/GAAS/MIME-Base64-Perl-1.00/source/lib/MIME/Base64/Perl.pm\nsub base64_decode_4 {\n    my ($str) = @_;\n    $str =~ tr|A-Za-z0-9+=/||cd;    # remove non-base64 chars\n    $str =~ s/=+$//;                # remove padding\n    $str =~ tr|A-Za-z0-9+/| -_|;    # convert to uuencoded format\n\n    my $uustr = '';\n    my ($i, $l);\n    $l = length($str) - 60;\n\n    for ($i = 0 ; $i <= $l ; $i += 60) {\n        $uustr .= \"M\" . substr($str, $i, 60);\n    }\n\n    $str = substr($str, $i);\n\n    # and any leftover chars\n    if ($str ne \"\") {\n        $uustr .= chr(32 + length($str) * 3 / 4) . $str;\n    }\n    return unpack(\"u\", $uustr);\n}\n\n# FASTEST (written in C)\nsub base64_decode_5 {\n    use MIME::Base64 qw(decode_base64);\n    return decode_base64($_[0]);\n}\n\n\n__END__\n\n# Some benchmarks\n\nmy $base64_text = <<'BASE64';\nQmFzZTY0IGVuY29kaW5nIGNhbiBiZSBoZWxwZnVsIHdoZW4gZmFpcmx5IGxlbmd0aHkgaWRlbnRp\nZnlpbmcgaW5mb3JtYXRpb24gaXMgdXNlZCBpbiBhbiBIVFRQIGVudmlyb25tZW50LiBGb3IgZXhh\nbXBsZSwgYSBkYXRhYmFzZSBwZXJzaXN0ZW5jZSBmcmFtZXdvcmsgZm9yIEphdmEgb2JqZWN0cyBt\naWdodCB1c2UgQmFzZTY0IGVuY29kaW5nIHRvIGVuY29kZSBhIHJlbGF0aXZlbHkgbGFyZ2UgdW5p\ncXVlIGlkIChnZW5lcmFsbHkgMTI4LWJpdCBVVUlEcykgaW50byBhIHN0cmluZyBmb3IgdXNlIGFz\nIGFuIEhUVFAgcGFyYW1ldGVyIGluIEhUVFAgZm9ybXMgb3IgSFRUUCBHRVQgVVJMcy4gQWxzbywg\nbWFueSBhcHBsaWNhdGlvbnMgbmVlZCB0byBlbmNvZGUgYmluYXJ5IGRhdGEgaW4gYSB3YXkgdGhh\ndCBpcyBjb252ZW5pZW50IGZvciBpbmNsdXNpb24gaW4gVVJMcywgaW5jbHVkaW5nIGluIGhpZGRl\nbiB3ZWIgZm9ybSBmaWVsZHMsIGFuZCBCYXNlNjQgaXMgYSBjb252ZW5pZW50IGVuY29kaW5nIHRv\nIHJlbmRlciB0aGVtIGluIG5vdCBvbmx5IGEgY29tcGFjdCB3YXksIGJ1dCBpbiBhIHJlbGF0aXZl\nbHkgdW5yZWFkYWJsZSBvbmUgd2hlbiB0cnlpbmcgdG8gb2JzY3VyZSB0aGUgbmF0dXJlIG9mIGRh\ndGEgZnJvbSBhIGNhc3VhbCBodW1hbiBvYnNlcnZlci4K\nBASE64\n\nuse Benchmark qw(timethese cmpthese);\n\nmy $results = timethese(\n                        10000,\n                        {\n                         'base64_decode_1' => sub { base64_decode_1($base64_text) },\n                         'base64_decode_2' => sub { base64_decode_2($base64_text) },\n                         'base64_decode_3' => sub { base64_decode_3($base64_text) },\n                         'base64_decode_4' => sub { base64_decode_4($base64_text) },\n                         'base64_decode_5' => sub { base64_decode_5($base64_text) },\n                        }\n                       );\ncmpthese($results);\n"
  },
  {
    "path": "Decoders/cnp_info.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 11 October 2012\n# https://github.com/trizen\n\n# CNP info\n\n# See also:\n#   https://ro.wikipedia.org/wiki/Cod_numeric_personal\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub usage {\n    die \"usage: $0 CNP\\n\";\n}\n\nmy @cnp = split //, shift // usage();\n\n(@cnp != 13 || join(q{}, @cnp) =~ /[^0-9]/) && die \"Invalid CNP!\\n\";\n\nmy @magic = qw(2 7 9 1 4 6 3 5 8 2 7 9);\n\nmy %year_num = (\n                1 => {era => 1900,},\n                2 => {era => 1900,},\n                3 => {era => 1800,},\n                4 => {era => 1800,},\n                5 => {era => 2000,},\n                6 => {era => 2000,},\n                7 => {\n                      era => 0,\n                      cet => \"Străin rezident în România\",\n                     },\n                8 => {\n                      era => 0,\n                      cet => \"Străin rezident în România\",\n                     },\n                9 => {\n                      era => 0,\n                      cet => \"Persoană străină\",\n                     }\n               );\n\nmy %jud = (\n           '01' => 'Alba',\n           '02' => 'Arad',\n           '03' => 'Argeș',\n           '04' => 'Bacău',\n           '05' => 'Bihor',\n           '06' => 'Bistrița-Năsăud',\n           '07' => 'Botoșani',\n           '08' => 'Brașov',\n           '09' => 'Brăila',\n           '10' => 'Buzău',\n           '11' => 'Caraș-Severin',\n           '12' => 'Cluj',\n           '13' => 'Constanța',\n           '14' => 'Covasna',\n           '15' => 'Dâmbovița',\n           '16' => 'Dolj',\n           '17' => 'Galați',\n           '18' => 'Gorj',\n           '19' => 'Harghita',\n           '20' => 'Hunedoara',\n           '21' => 'Ialomița',\n           '22' => 'Iași',\n           '23' => 'Ilfov',\n           '24' => 'Maramureș',\n           '25' => 'Mehedinți',\n           '26' => 'Mureș',\n           '27' => 'Neamț',\n           '28' => 'Olt',\n           '29' => 'Prahova',\n           '30' => 'Satu Mare',\n           '31' => 'Sălaj',\n           '32' => 'Sibiu',\n           '33' => 'Suceava',\n           '34' => 'Teleorman',\n           '35' => 'Timiș',\n           '36' => 'Tulcea',\n           '37' => 'Vaslui',\n           '38' => 'Vâlcea',\n           '39' => 'Vrancea',\n           '40' => 'București',\n           '41' => 'București S.1',\n           '42' => 'București S.2',\n           '43' => 'București S.3',\n           '44' => 'București S.4',\n           '45' => 'București S.5',\n           '46' => 'București S.6',\n           '51' => 'Călărași',\n           '52' => 'Giurgiu',\n          );\n\nmy @months = qw(\n  Ianuarie\n  Februarie\n  Martie\n  Aprilie\n  Mai\n  Iunie\n  Iulie\n  August\n  Septembrie\n  Octombrie\n  Noiembrie\n  Decembrie\n  );\n\nmy %days;\n@days{@months} = qw(\n  31\n  29\n  31\n  30\n  31\n  30\n  31\n  31\n  30\n  31\n  30\n  31\n  );\n\nmy $sum = 0;\n$sum += $magic[$_] * $cnp[$_] for 0 .. $#magic;\n\nmy $cc = $sum % 11;\n$cc = 1 if $cc == 10;\n\nif ($cc != $cnp[-1]) {\n    die \"Cifra de control e incorectă!\\n\";\n}\n\nmy $hash_ref = $year_num{$cnp[0]};\n\nmy $year_num  = \"$cnp[1]$cnp[2]\";\nmy $month_num = \"$cnp[3]$cnp[4]\";\nmy $day_num   = \"$cnp[5]$cnp[6]\";\nmy $jud_num   = \"$cnp[7]$cnp[8]\";\n\nif ($month_num < 1 or $month_num > 12) {\n    die \"Luna de naștere e invalidă!\\n\";\n}\n\nmy $cur_day  = [localtime]->[3];\nmy $cur_mon  = [localtime]->[4] + 1;\nmy $cur_year = [localtime]->[5];\n\nmy $nationality = \"Română\";\nif ($hash_ref->{era} == 0) {\n    $hash_ref->{era} = $year_num < $cur_year - 100 ? 2000 : 1900;\n    $nationality = $hash_ref->{cet} // 'Necunoscută';\n}\n\nmy $birth_year = $hash_ref->{era} + $year_num;\nmy $month_name = $months[$month_num - 1];\n\nif ($day_num > $days{$month_name} or $day_num < 1) {\n    die \"Ziua de naștere e invalidă!\\n\";\n}\n\nmy $jud_name = $jud{$jud_num} // die \"Codul județului e invalid!\\n\";\n\nif ($month_num == 2 and $day_num == 29) {\n    die \"Anul $birth_year nu a fost un an bisect!\\n\"\n      if not($birth_year % 400 == 0 or $birth_year % 4 == 0 and $birth_year % 100 != 0);\n}\n\nmy $age = $cur_year + 1900 - $birth_year;\nif ($cur_mon < $month_num or ($month_num == $cur_mon and $day_num < $cur_day)) {\n    --$age;\n}\n\nmy $gender =\n  $cnp[0] == 9\n  ? \"Necunoscut\"\n  : (\"Feminin\", \"Masculin\")[$cnp[0] % 2];\n\nprintf <<\"EOF\",\nData Nașterii:  %s\nCetațenie:      %s\nSexul:          %s\nVârsta:         %s\nJudețul:        %s\nEOF\n  \"$day_num $month_name $birth_year\", $nationality, $gender, $age, $jud_name;\n"
  },
  {
    "path": "Decoders/named_parameters.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 23 October 2015\n# Website: https://github.com/trizen\n\n# Code-concept for implementing the \"named-parameters\" feature in programming languages.\n\n=for Sidef example:\n\n    func test (x, y, z) {\n        say (x, y, z);      # prints: '123'\n    }\n\n    test(1,2,3);\n    test(1, y: 2, z: 3);\n    test(x: 1, y: 2, z: 3);\n    test(y: 2, z: 3, x: 1);\n    ...\n\n=cut\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse List::Util qw(shuffle);\n\nsub test {\n    my @args = @_;\n    my @vars = (\\my $x, \\my $y, \\my $z);\n\n    my %table = (\n                 x => 0,\n                 y => 1,\n                 z => 2,\n                );\n\n    my @left;\n    my %seen;\n\n    foreach my $arg (@args) {\n        if (ref($arg) eq 'ARRAY') {\n            if (exists $table{$arg->[0]}) {\n                ${$vars[$table{$arg->[0]}]} = $arg->[1];\n                undef $seen{$vars[$table{$arg->[0]}]};\n            }\n            else {\n                die \"No such named argument: <<$arg->[0]>>\";\n            }\n        }\n        else {\n            push @left, $arg;\n        }\n    }\n\n    foreach my $var (@vars) {\n        next if exists $seen{$var};\n        if (@left) {\n            ${$var} = shift @left;\n        }\n    }\n\n    say \"$x $y $z\";\n    ($x == 1 and $y == 2 and $z == 3) or die \"error!\";\n}\n\ntest(1, ['y', 2], 3);\ntest(1, 3, ['y', 2]);\ntest(1, ['z', 3], 2);\ntest(1, 2, ['z', 3]);\ntest(1, 3, ['y', 2]);\ntest(['y', 2], 1, 3);\ntest(['x', 1], ['z', 3], ['y', 2]);\ntest(shuffle(['x', 1], 3, ['y', 2]));\ntest(shuffle(['x', 1], 2, ['z', 3]));\ntest(shuffle(1, ['y', 2], ['z', 3]));\ntest(shuffle(['z', 3], ['x', 1], ['y', 2]));\ntest(shuffle(['z', 3], 1, ['y', 2]));\n"
  },
  {
    "path": "Digest/brute-force_resistant_hashing.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 21 December 2021\n# https://github.com/trizen\n\n# A concept for a brute-force resistant hashing method.\n\n# It requires a deterministic hash function, which is used in computing a\n# non-deterministic brute-force resistant hash, based on the processor speed\n# of the computer, taking about 2 seconds to hash a password, and about 1.5 seconds\n# to verify if the hash of a password is correct, given the password and the hash.\n\n# The method can be made deterministic, by providing a fixed number of iterations.\n# Otherwise, the method automatically computes a safe number of iterations based on hardware speed.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Bcrypt\n#   https://en.wikipedia.org/wiki/Argon2\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Digest::SHA qw(sha512_hex);\nuse experimental qw(signatures);\n\nsub bfr_hash ($password, $hash_function, $iterations = undef) {\n\n    my $strength = 1;    # delay time in seconds\n\n    my $salt_hash = $hash_function->('');\n    my $pass_hash = $hash_function->($password);\n\n    my $hash_password = sub {\n        $salt_hash = $hash_function->($salt_hash);\n        $pass_hash = $hash_function->($salt_hash . $pass_hash);\n        #$pass_hash = $hash_function->($pass_hash . $salt_hash);\n    };\n\n    if (defined $iterations) {\n        for (1 .. $iterations) {\n            $hash_password->();\n        }\n    }\n    else {\n\n        $iterations = 0;\n\n        eval {\n            local $SIG{ALRM} = sub { die \"alarm\\n\" };\n            alarm $strength;\n\n            while (1) {\n                $hash_password->();\n                ++$iterations;\n            }\n\n            alarm 0;\n        };\n\n        say \"[DEBUG] Iterations: $iterations\";\n        return __SUB__->($password, $hash_function, $iterations);\n    }\n\n    my $check_hash = $hash_function->($pass_hash . $salt_hash);\n    return join('$', $pass_hash, $salt_hash, $check_hash);\n}\n\nsub check_bfr_hash ($password, $bfr_hash, $hash_function) {\n    my ($pass_hash, $salt_hash, $check_hash) = split(/\\$/, $bfr_hash);\n\n    $salt_hash  // return 0;\n    $pass_hash  // return 0;\n    $check_hash // return 0;\n\n    if ($hash_function->($pass_hash . $salt_hash) ne $check_hash) {\n        return 0;\n    }\n\n    my $iterations = 0;\n    my $hash       = $hash_function->('');\n\n    while (1) {\n        $hash = $hash_function->($hash);\n        ++$iterations;\n        last if ($hash eq $salt_hash);\n    }\n\n    if (bfr_hash($password, $hash_function, $iterations) eq $bfr_hash) {\n        return 1;\n    }\n\n    return 0;\n}\n\nmy $password1 = 'foo';\nmy $password2 = 'bar';\n\nmy $hash1 = bfr_hash($password1, \\&sha512_hex);\nmy $hash2 = bfr_hash($password2, \\&sha512_hex);\n\nsay qq{bfr_hash(\"$password1\", sha512) = $hash1};\nsay qq{bfr_hash(\"$password2\", sha512) = $hash2};\n\nsay check_bfr_hash($password1, $hash1, \\&sha512_hex);    #=> 1\nsay check_bfr_hash($password2, $hash2, \\&sha512_hex);    #=> 1\nsay check_bfr_hash($password1, $hash2, \\&sha512_hex);    #=> 0\nsay check_bfr_hash($password2, $hash1, \\&sha512_hex);    #=> 0\n\n__END__\nbfr_hash(\"foo\", sha512) = d0cd2ed4ef19e55ea8d69212417e21d5723e41a716f74fea2bbc7d8e114108d1a439c763b2673c2e79ccc684b7558d42956982d6396abd6bcd99aca30b516787$a65bff3e58823c51d7a4a44bcebc8f5c8ba148e3eea81fc017ecd20eb94b5892f2112e397a48e5185ab500051ec285a0a9d104a6eed4828d04cc0661c0ea1885$03061c61439174d1a4f8f3fa73e53ff9b9480f02afa270544aaeacfc6cc08db27742f2d3721edc13a4cefabb0accbf476ef6c9596932fc81816c018e8fd6ca6e\nbfr_hash(\"bar\", sha512) = 3eefe86bfbc36d7099625a3b3ab741c373435ab873d841eccbf9db465637b0c7a7e612cbc65fda0a9333c2065d10cbcb8120a8271b932234849753f899c4c396$906e9a62689d2bc012ff83f777432a2b1235faeff01a582d1fb3eb6b5201f1bca4174a4a983b6951fb211936d2040468c2a695f7b74ad45dcb76789ef267b9a9$e5bc95297be88c0b8003c731a052968ed6c2c75fceea2844e2584fdd05ae97ffa1795dc7f73e6b9c9c7c91d294dc7f435d687221fbf945d6d590fce7f54fcf7d\n"
  },
  {
    "path": "Digest/crc32.pl",
    "content": "#!/usr/bin/perl\n\n# Simple implementation of the Cyclic Redundancy Check (CRC32).\n\n# Reference:\n#   https://web.archive.org/web/20240718094514/https://rosettacode.org/wiki/CRC-32\n\nuse 5.036;\n\nsub create_table() {\n    my @table;\n    for my $i (0 .. 255) {\n        my $k = $i;\n        for (0 .. 7) {\n            if ($k & 1) {\n                $k >>= 1;\n                $k ^= 0xedb88320;\n            }\n            else {\n                $k >>= 1;\n            }\n        }\n        push @table, $k;\n    }\n    return \\@table;\n}\n\nsub crc32($str, $crc = 0) {\n    state $crc_table = create_table();\n    $crc ^= 0xffffffff;\n    foreach my $c (unpack(\"C*\", $str)) {\n        $crc = ($crc >> 8) ^ $crc_table->[($crc & 0xff) ^ $c];\n    }\n    return ($crc ^ 0xffffffff);\n}\n\nsay crc32 \"The quick brown fox jumps over the lazy dog\";\nsay crc32(\"over the lazy dog\", crc32(\"The quick brown fox jumps \"));\n"
  },
  {
    "path": "Encoding/adaptive_huffman_coding.pl",
    "content": "#!/usr/bin/perl\n\n# Implementation of the Adaptive Huffman Coding.\n\n# See also:\n#   https://rosettacode.org/wiki/huffman_coding\n\nuse 5.036;\nuse List::Util qw(uniq);\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub encode ($bytes, $alphabet) {\n\n    my %freq;\n    ++$freq{$_} for @$alphabet;\n\n    my @enc;\n    foreach my $byte (@$bytes) {\n        my ($h, $rev_h) = mktree_from_freq(\\%freq);\n        ++$freq{$byte};\n        push @enc, $h->{$byte};\n    }\n\n    return join('', @enc);\n}\n\nsub decode ($enc, $alphabet) {\n\n    my @out;\n    my $prefix = '';\n\n    my %freq;\n    ++$freq{$_} for @$alphabet;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n\n    foreach my $bit (split(//, $enc)) {\n        $prefix .= $bit;\n        if (exists $rev_h->{$prefix}) {\n            push @out, $rev_h->{$prefix};\n            ++$freq{$rev_h->{$prefix}};\n            ($h, $rev_h) = mktree_from_freq(\\%freq);\n            $prefix = '';\n        }\n    }\n\n    return \\@out;\n}\n\nmy $text     = \"this is an example for huffman encoding\";\nmy @bytes    = unpack('C*', $text);\nmy @alphabet = uniq(@bytes);\n\nmy $enc = encode(\\@bytes, \\@alphabet);\nmy $dec = decode($enc, \\@alphabet);\n\nsay $enc;\nsay pack('C*', @$dec);\n\n__END__\n1010000100010111110101010101010001010011011000101100010010010111110001011011111000011100111101111100111010110111011100111100011011100010001101100010011100000100010110001010\nthis is an example for huffman encoding\n"
  },
  {
    "path": "Encoding/arithmetic_coding.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 01 May 2015\n# https://github.com/trizen\n\n# The arithmetic coding algorithm, as_a_generalized_change_of_radix.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Arithmetic_coding#Arithmetic_coding_as_a_generalized_change_of_radix\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::BigInt (try => 'GMP');\n\nsub asciibet {\n    map { chr } 0 .. 255;\n}\n\nsub cumulative_freq {\n    my ($freq) = @_;\n\n    my %cf;\n    my $total = Math::BigInt->new(0);\n    foreach my $c (asciibet()) {\n        if (exists $freq->{$c}) {\n            $cf{$c} = $total;\n            $total += $freq->{$c};\n        }\n    }\n\n    return %cf;\n}\n\nsub arithmethic_coding {\n    my ($str, $radix) = @_;\n    my @chars = split(//, $str);\n\n    # The frequency characters\n    my %freq;\n    $freq{$_}++ for @chars;\n\n    # The cumulative frequency table\n    my %cf = cumulative_freq(\\%freq);\n\n    # Limit and base\n    my $base = scalar @chars;\n\n    # Lower bound\n    my $L = Math::BigInt->new(0);\n\n    # Product of all frequencies\n    my $pf = Math::BigInt->new(1);\n\n    # Each term is multiplied by the product of the\n    # frequencies of all previously occurring symbols\n    foreach my $c (@chars) {\n        $L->bmuladd($base, $cf{$c} * $pf);\n        $pf->bmul($freq{$c});\n    }\n\n    # Upper bound\n    my $U = $L + $pf;\n\n    #~ say $L;\n    #~ say $U;\n\n    my $pow = Math::BigInt->new($pf)->blog($radix);\n    my $enc = ($U - 1)->bdiv(Math::BigInt->new($radix)->bpow($pow));\n\n    return ($enc, $pow, \\%freq);\n}\n\nsub arithmethic_decoding {\n    my ($enc, $radix, $pow, $freq) = @_;\n\n    # Multiply enc by 10^pow\n    $enc *= $radix**$pow;\n\n    my $base = Math::BigInt->new(0);\n    $base += $_ for values %{$freq};\n\n    # Create the cumulative frequency table\n    my %cf = cumulative_freq($freq);\n\n    # Create the dictionary\n    my %dict;\n    while (my ($k, $v) = each %cf) {\n        $dict{$v} = $k;\n    }\n\n    # Fill the gaps in the dictionary\n    my $lchar;\n    foreach my $i (0 .. $base - 1) {\n        if (exists $dict{$i}) {\n            $lchar = $dict{$i};\n        }\n        elsif (defined $lchar) {\n            $dict{$i} = $lchar;\n        }\n    }\n\n    # Decode the input number\n    my $decoded = '';\n    for (my $i = $base - 1 ; $i >= 0 ; $i--) {\n\n        my $pow = $base**$i;\n        my $div = ($enc / $pow);\n\n        my $c  = $dict{$div};\n        my $fv = $freq->{$c};\n        my $cv = $cf{$c};\n\n        my $rem = ($enc - $pow * $cv) / $fv;\n\n        #~ say \"$enc / $base^$i = $div ($c)\";\n        #~ say \"($enc - $base^$i * $cv) / $fv = $rem\\n\";\n\n        $enc = $rem;\n        $decoded .= $c;\n    }\n\n    # Return the decoded output\n    return $decoded;\n}\n\n#\n## Run some tests\n#\n\nmy $radix = 10;    # can be any integer >= 2\n\nforeach my $str (\n                 qw(DABDDB DABDDBBDDBA ABBDDD ABRACADABRA CoMpReSSeD Sidef Trizen google TOBEORNOTTOBEORTOBEORNOT 吹吹打打),\n                 'In a positional numeral system the radix, or base, is numerically equal to a number of different symbols '\n                 . 'used to express the number. For example, in the decimal system the number of symbols is 10, namely 0, 1, 2, '\n                 . '3, 4, 5, 6, 7, 8, and 9. The radix is used to express any finite integer in a presumed multiplier in polynomial '\n                 . 'form. For example, the number 457 is actually 4×102 + 5×101 + 7×100, where base 10 is presumed but not shown explicitly.'\n  ) {\n    my ($enc, $pow, $freq) = arithmethic_coding($str, $radix);\n    my $dec = arithmethic_decoding($enc, $radix, $pow, $freq);\n\n    say \"Encoded:  $enc\";\n    say \"Decoded:  $dec\";\n\n    if ($str ne $dec) {\n        die \"\\tHowever that is incorrect!\";\n    }\n\n    say \"-\" x 80;\n}\n"
  },
  {
    "path": "Encoding/arithmetic_coding_adaptive_contexts_in_fixed_bits.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 12 July 2023\n# Edit: 06 February 2024\n# https://github.com/trizen\n\n# The Arithmetic Coding algorithm (adaptive version), implemented using native integers.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 15 - Infinite Precision in Finite Bits\n#   https://youtube.com/watch?v=EqKbT3QdtOI\n#\n#   Data Compression (Summer 2023) - Lecture 16 - Adaptive Methods\n#   https://youtube.com/watch?v=YKv-w8bXi9c\n\nuse 5.036;\n\nuse constant {\n              ESCAPE => 256,\n              EOF    => 257,\n             };\n\nuse constant BITS => 32;\nuse constant MAX  => oct('0b' . ('1' x BITS));\n\nsub create_cfreq ($table) {\n\n    my $T = 0;\n    my (@cf, @freq);\n\n    foreach my $pair (@$table) {\n        my ($i, $v) = @$pair;\n        $v ||= 1;    # FIXME: make it work with v = 0\n        $freq[$i] = $v;\n        $cf[$i]   = $T;\n        $T += $v;\n        $cf[$i + 1] = $T;\n    }\n\n    return (\\@freq, \\@cf, $T);\n}\n\nsub create_contexts {\n\n    my @C;\n\n    foreach my $i (0 .. 1) {\n\n        my ($freq, $cf, $T) =\n          create_cfreq(\n                       [(map { [$_, 1 - $i] } 0 .. 255),\n                        (\n                           ($i == 0)\n                         ? ([ESCAPE, 0], [EOF, 1])\n                         : ([ESCAPE, 1], [EOF, 1])\n                        ),\n                       ]\n                      );\n\n        push @C,\n          {\n            low      => 0,\n            high     => MAX,\n            freq     => $freq,\n            cf       => $cf,\n            T        => $T,\n            uf_count => 0,\n          };\n    }\n\n    return @C;\n}\n\nsub increment_freq ($c, $freq, $cf) {\n\n    if ($c <= 255) {\n        ++$freq->[$c];\n    }\n\n    my $T = $cf->[$c];\n\n    foreach my $i ($c .. 257) {\n        $cf->[$i] = $T;\n        $T += $freq->[$i];\n        $cf->[$i + 1] = $T;\n    }\n\n    return $T;\n}\n\nsub encode ($string) {\n\n    my $enc   = '';\n    my $bytes = [unpack('C*', $string), EOF];\n\n    my @C = create_contexts();\n\n    if ($C[0]{T} > MAX) {\n        die \"Too few bits:  $C[0]{T} > \", MAX;\n    }\n\n    my sub encode_symbol ($c, $context) {\n\n        my $w = $C[$context]{high} - $C[$context]{low} + 1;\n        $C[$context]{high} = ($C[$context]{low} + int(($w * $C[$context]{cf}[$c + 1]) / $C[$context]{T}) - 1) & MAX;\n        $C[$context]{low}  = ($C[$context]{low} + int(($w * $C[$context]{cf}[$c]) / $C[$context]{T})) & MAX;\n\n        foreach my $context (1) {\n            $C[$context]{T} = increment_freq($c, $C[$context]{freq}, $C[$context]{cf});\n        }\n\n        if ($C[$context]{high} > MAX) {\n            die \"high > MAX: $C[$context]{high} > ${\\MAX}\";\n        }\n\n        if ($C[$context]{low} >= $C[$context]{high}) {\n            die \"$C[$context]{low} >= $C[$context]{high}\";\n        }\n\n        while (1) {\n\n            if (($C[$context]{high} >> (BITS - 1)) == ($C[$context]{low} >> (BITS - 1))) {\n\n                my $bit = $C[$context]{high} >> (BITS - 1);\n                $enc .= $bit;\n\n                if ($C[$context]{uf_count} > 0) {\n                    $enc .= join('', 1 - $bit) x $C[$context]{uf_count};\n                    $C[$context]{uf_count} = 0;\n                }\n\n                $C[$context]{low} <<= 1;\n                ($C[$context]{high} <<= 1) |= 1;\n            }\n            elsif (((($C[$context]{low} >> (BITS - 2)) & 0x1) == 1) && ((($C[$context]{high} >> (BITS - 2)) & 0x1) == 0)) {\n                ($C[$context]{high} <<= 1) |= (1 << (BITS - 1));\n                $C[$context]{high} |= 1;\n                ($C[$context]{low} <<= 1) &= ((1 << (BITS - 1)) - 1);\n                ++$C[$context]{uf_count};\n            }\n            else {\n                last;\n            }\n\n            $C[$context]{low}  &= MAX;\n            $C[$context]{high} &= MAX;\n        }\n    }\n\n    foreach my $c (@$bytes) {\n        if ($C[1]{freq}[$c] == 0) {\n            encode_symbol(ESCAPE, 1);\n            encode_symbol($c,     0);\n        }\n        else {\n            encode_symbol($c, 1);\n        }\n    }\n\n    $enc .= '0';\n    $enc .= '1';\n\n    while (length($enc) % 8 != 0) {\n        $enc .= '1';\n    }\n\n    return $enc;\n}\n\nsub decode ($bits) {\n    open my $fh, '<:raw', \\$bits;\n\n    my @C = create_contexts();\n\n    my $dec = '';\n    my $enc = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS);\n\n    my $context = 1;\n\n    while (1) {\n\n        my $w  = $C[$context]{high} - $C[$context]{low} + 1;\n        my $ss = int((($C[$context]{T} * ($enc - $C[$context]{low} + 1)) - 1) / $w);\n\n        my $i    = undef;\n        my $cf   = $C[$context]{cf};\n        my $freq = $C[$context]{freq};\n\n        foreach my $j (0 .. 257) {\n            $freq->[$j] > 0 or next;\n            if ($cf->[$j] <= $ss and $ss < $cf->[$j + 1]) {\n                $i = $j;\n                last;\n            }\n        }\n\n        $i // die \"decoding error\";\n\n        last if ($i == EOF);\n\n        if ($i <= 255) {\n            $dec .= chr($i);\n        }\n\n        $C[$context]{high} = ($C[$context]{low} + int(($w * $C[$context]{cf}[$i + 1]) / $C[$context]{T}) - 1) & MAX;\n        $C[$context]{low}  = ($C[$context]{low} + int(($w * $C[$context]{cf}[$i]) / $C[$context]{T})) & MAX;\n\n        foreach my $context (1) {\n            $C[$context]{T} = increment_freq($i, $C[$context]{freq}, $C[$context]{cf});\n        }\n\n        if ($C[$context]{high} > MAX) {\n            die \"high > MAX: ($C[$context]{high} > ${\\MAX})\";\n        }\n\n        if ($C[$context]{low} >= $C[$context]{high}) {\n            die \"$C[$context]{low} >= $C[$context]{high}\";\n        }\n\n        while (1) {\n\n            if (($C[$context]{high} >> (BITS - 1)) == ($C[$context]{low} >> (BITS - 1))) {\n                ($C[$context]{high} <<= 1) |= 1;\n                $C[$context]{low} <<= 1;\n                ($enc <<= 1) |= (getc($fh) // 1);\n            }\n            elsif (((($C[$context]{low} >> (BITS - 2)) & 0x1) == 1) && ((($C[$context]{high} >> (BITS - 2)) & 0x1) == 0)) {\n                ($C[$context]{high} <<= 1) |= (1 << (BITS - 1));\n                $C[$context]{high} |= 1;\n                ($C[$context]{low} <<= 1) &= ((1 << (BITS - 1)) - 1);\n                $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1);\n            }\n            else {\n                last;\n            }\n\n            $C[$context]{low}  &= MAX;\n            $C[$context]{high} &= MAX;\n            $enc               &= MAX;\n        }\n\n        if ($i == ESCAPE) {\n            $context == 1 or die \"error\";\n            $context = 0;\n        }\n        elsif ($context == 0) {\n            $context = 1;\n        }\n    }\n\n    return $dec;\n}\n\nmy $str = \"ABRACADABRA AND A VERY SAD SALAD\";\n\nif (@ARGV) {\n    if (-f $ARGV[0]) {\n        $str = do {\n            open my $fh, '<:raw', $ARGV[0];\n            local $/;\n            <$fh>;\n        };\n    }\n    else {\n        $str = $ARGV[0];\n    }\n}\n\nmy ($enc) = encode($str);\n\nsay $enc;\nsay \"Encoded bytes length: \", length($enc) / 8;\n\nmy $dec = decode($enc);\nsay $dec;\n$str eq $dec or die \"Decoding error: \", length($str), ' <=> ', length($dec);\n\n__END__\n0100000011000001000010010011111111110001001000010100100101000010110101110111001000110110110010011001000111010101100010111110010111111101011110010010110000110100100101110011110101110111101000110000011100010111111100001010011011001011\nEncoded bytes length: 29\nABRACADABRA AND A VERY SAD SALAD\n"
  },
  {
    "path": "Encoding/arithmetic_coding_adaptive_in_fixed_bits.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 12 July 2023\n# Edit: 05 February 2024\n# https://github.com/trizen\n\n# The Arithmetic Coding algorithm (adaptive version), implemented using native integers.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 15 - Infinite Precision in Finite Bits\n#   https://youtube.com/watch?v=EqKbT3QdtOI\n#\n#   Data Compression (Summer 2023) - Lecture 16 - Adaptive Methods\n#   https://youtube.com/watch?v=YKv-w8bXi9c\n#\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.036;\n\nuse List::Util qw(max);\n\nuse constant EOF_SYMBOL => 256;\nuse constant BITS       => 32;\nuse constant MAX        => oct('0b' . ('1' x BITS));\n\nsub create_cfreq ($freq_value) {\n\n    my $T = 0;\n    my (@cf, @freq);\n\n    foreach my $i (0 .. EOF_SYMBOL) {\n        $freq[$i] = $freq_value;\n        $cf[$i]   = $T;\n        $T += $freq_value;\n        $cf[$i + 1] = $T;\n    }\n\n    return (\\@freq, \\@cf, $T);\n}\n\nsub increment_freq ($c, $freq, $cf) {\n\n    ++$freq->[$c];\n    my $T = $cf->[$c];\n\n    foreach my $i ($c .. EOF_SYMBOL) {\n        $cf->[$i] = $T;\n        $T += $freq->[$i];\n        $cf->[$i + 1] = $T;\n    }\n\n    return $T;\n}\n\nsub encode ($string) {\n\n    my $enc   = '';\n    my $bytes = [unpack('C*', $string), EOF_SYMBOL];\n\n    my ($freq, $cf, $T) = create_cfreq(1);\n\n    if ($T > MAX) {\n        die \"Too few bits: $T > ${\\MAX}\";\n    }\n\n    my $low      = 0;\n    my $high     = MAX;\n    my $uf_count = 0;\n\n    foreach my $c (@$bytes) {\n\n        my $w = $high - $low + 1;\n\n        $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$c]) / $T)) & MAX;\n\n        $T = increment_freq($c, $freq, $cf);\n\n        if ($high > MAX) {\n            die \"high > MAX: $high > ${\\MAX}\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n\n                my $bit = $high >> (BITS - 1);\n                $enc .= $bit;\n\n                if ($uf_count > 0) {\n                    $enc .= join('', 1 - $bit) x $uf_count;\n                    $uf_count = 0;\n                }\n\n                $low <<= 1;\n                ($high <<= 1) |= 1;\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                ++$uf_count;\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n        }\n    }\n\n    $enc .= '0';\n    $enc .= '1';\n\n    while (length($enc) % 8 != 0) {\n        $enc .= '1';\n    }\n\n    return $enc;\n}\n\nsub decode ($bits) {\n    open my $fh, '<:raw', \\$bits;\n\n    my ($freq, $cf, $T) = create_cfreq(1);\n\n    my $dec  = '';\n    my $low  = 0;\n    my $high = MAX;\n    my $enc  = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS);\n\n    while (1) {\n\n        my $w  = $high - $low + 1;\n        my $ss = int((($T * ($enc - $low + 1)) - 1) / $w);\n\n        my $i = 0;\n        foreach my $j (0 .. EOF_SYMBOL) {\n            if ($cf->[$j] <= $ss and $ss < $cf->[$j + 1]) {\n                $i = $j;\n                last;\n            }\n        }\n\n        last if ($i == EOF_SYMBOL);\n\n        $dec .= chr($i);\n\n        $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$i]) / $T)) & MAX;\n\n        $T = increment_freq($i, $freq, $cf);\n\n        if ($high > MAX) {\n            die \"error\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n                ($high <<= 1) |= 1;\n                $low <<= 1;\n                ($enc <<= 1) |= (getc($fh) // 1);\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1);\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n            $enc  &= MAX;\n        }\n    }\n\n    return $dec;\n}\n\nmy $str = \"ABRACADABRA AND A VERY SAD SALAD\";\n\nif (@ARGV) {\n    if (-f $ARGV[0]) {\n        $str = do {\n            open my $fh, '<:raw', $ARGV[0];\n            local $/;\n            <$fh>;\n        };\n    }\n    else {\n        $str = $ARGV[0];\n    }\n}\n\nmy ($enc) = encode($str);\n\nsay $enc;\nsay \"Encoded bytes length: \", length($enc) / 8;\n\nmy $dec = decode($enc);\nsay $dec;\n$str eq $dec or die \"Decoding error: \", length($str), ' <=> ', length($dec);\n\n__END__\n0100000100000001110010111101111100111011001101010100000111010101101011111111010100110100011111001010110010110110010001001100100111000101010111111101011110101001010110111111000111101000010110011000010100100111110010011111110111011111\nEncoded bytes length: 29\nABRACADABRA AND A VERY SAD SALAD\n"
  },
  {
    "path": "Encoding/arithmetic_coding_anynum.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 01 May 2015\n# https://github.com/trizen\n\n# The arithmetic coding algorithm, as_a_generalized_change_of_radix.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Arithmetic_coding#Arithmetic_coding_as_a_generalized_change_of_radix\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(ipow ilog idiv);\n\nsub asciibet {\n    map { chr } 0 .. 255;\n}\n\nsub cumulative_freq {\n    my ($freq) = @_;\n\n    my %cf;\n    my $total = Math::AnyNum->new(0);\n    foreach my $c (asciibet()) {\n        if (exists $freq->{$c}) {\n            $cf{$c} = $total;\n            $total += $freq->{$c};\n        }\n    }\n\n    return %cf;\n}\n\nsub arithmethic_coding {\n    my ($str, $radix) = @_;\n    my @chars = split(//, $str);\n\n    # The frequency characters\n    my %freq;\n    $freq{$_}++ for @chars;\n\n    # The cumulative frequency table\n    my %cf = cumulative_freq(\\%freq);\n\n    # Base\n    my $base = Math::AnyNum->new(scalar @chars);\n\n    # Lower bound\n    my $L = Math::AnyNum->new(0);\n\n    # Product of all frequencies\n    my $pf = Math::AnyNum->new(1);\n\n    # Each term is multiplied by the product of the\n    # frequencies of all previously occurring symbols\n    foreach my $c (@chars) {\n        $L  *= $base;\n        $L  += $cf{$c} * $pf;\n        $pf *= $freq{$c};\n    }\n\n    # Upper bound\n    my $U = $L + $pf;\n\n    #~ say $L;\n    #~ say $U;\n\n    my $pow = ilog($pf, $radix);\n    my $enc = idiv($U - 1, ipow($radix, $pow));\n\n    return ($enc, $pow, \\%freq);\n}\n\nsub arithmethic_decoding {\n    my ($enc, $radix, $pow, $freq) = @_;\n\n    # Multiply enc by 10^pow\n    $enc *= ipow($radix, $pow);\n\n    my $base = Math::AnyNum->new(0);\n    $base += $_ for values %{$freq};\n\n    # Create the cumulative frequency table\n    my %cf = cumulative_freq($freq);\n\n    # Create the dictionary\n    my %dict;\n    while (my ($k, $v) = each %cf) {\n        $dict{$v} = $k;\n    }\n\n    # Fill the gaps in the dictionary\n    my $lchar;\n    foreach my $i (0 .. $base - 1) {\n        if (exists $dict{$i}) {\n            $lchar = $dict{$i};\n        }\n        elsif (defined $lchar) {\n            $dict{$i} = $lchar;\n        }\n    }\n\n    # Decode the input number\n    my $decoded = '';\n    for (my $pow = ipow($base, $base - 1) ; $pow > 0 ; $pow = idiv($pow, $base)) {\n        my $div = idiv($enc, $pow);\n\n        my $c  = $dict{$div};\n        my $fv = $freq->{$c};\n        my $cv = $cf{$c};\n\n        my $rem = idiv($enc - $pow * $cv, $fv);\n\n        #~ say \"$enc / $base^$pow = $div ($c)\";\n        #~ say \"($enc - $base^$pow * $cv) / $fv = $rem\\n\";\n\n        $enc = $rem;\n        $decoded .= $c;\n    }\n\n    # Return the decoded output\n    return $decoded;\n}\n\n#\n## Run some tests\n#\n\nmy $radix = 10;    # can be any integer >= 2\n\nforeach my $str (\n                 qw(DABDDB DABDDBBDDBA ABBDDD ABRACADABRA CoMpReSSeD Sidef Trizen google TOBEORNOTTOBEORTOBEORNOT 吹吹打打),\n                 'In a positional numeral system the radix, or base, is numerically equal to a number of different symbols '\n                 . 'used to express the number. For example, in the decimal system the number of symbols is 10, namely 0, 1, 2, '\n                 . '3, 4, 5, 6, 7, 8, and 9. The radix is used to express any finite integer in a presumed multiplier in polynomial '\n                 . 'form. For example, the number 457 is actually 4×102 + 5×101 + 7×100, where base 10 is presumed but not shown explicitly.'\n  ) {\n    my ($enc, $pow, $freq) = arithmethic_coding($str, $radix);\n    my $dec = arithmethic_decoding($enc, $radix, $pow, $freq);\n\n    say \"Encoded:  $enc\";\n    say \"Decoded:  $dec\";\n\n    if ($str ne $dec) {\n        die \"\\tHowever that is incorrect!\";\n    }\n\n    say \"-\" x 80;\n}\n\nopen my $fh, '<', __FILE__;\nmy $content = do { local $/; <$fh> };\n\nmy ($enc, $pow, $freq) = arithmethic_coding($content, $radix);\nmy $dec = arithmethic_decoding($enc, $radix, $pow, $freq);\n\nif ($dec ne $content) {\n    die \"Failed to encode and decode the __FILE__ correctly.\";\n}\n"
  },
  {
    "path": "Encoding/arithmetic_coding_in_fixed_bits.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 12 July 2023\n# Edit: 05 February 2024\n# https://github.com/trizen\n\n# The Arithmetic Coding algorithm, implemented using native integers.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 15 - Infinite Precision in Finite Bits\n#   https://youtube.com/watch?v=EqKbT3QdtOI\n#\n#   Basic arithmetic coder in C++\n#   https://github.com/billbird/arith32\n\nuse 5.036;\n\nuse List::Util qw(max);\n\nuse constant BITS => 32;\nuse constant MAX  => oct('0b' . ('1' x BITS));\n\nsub create_cfreq ($freq) {\n\n    my @cf;\n    my $T = 0;\n\n    foreach my $i (sort { $a <=> $b } keys %$freq) {\n        $freq->{$i} // next;\n        $cf[$i] = $T;\n        $T += $freq->{$i};\n        $cf[$i + 1] = $T;\n    }\n\n    return (\\@cf, $T);\n}\n\nsub encode ($string) {\n\n    my $enc   = '';\n    my @bytes = unpack('C*', $string);\n\n    my $EOF_SYMBOL = (max(@bytes) // 0) + 1;\n    push @bytes, $EOF_SYMBOL;\n\n    my %freq;\n    ++$freq{$_} for @bytes;\n\n    my ($cf, $T) = create_cfreq(\\%freq);\n\n    if ($T > MAX) {\n        die \"Too few bits: $T > ${\\MAX}\";\n    }\n\n    my $low      = 0;\n    my $high     = MAX;\n    my $uf_count = 0;\n\n    foreach my $c (@bytes) {\n\n        my $w = $high - $low + 1;\n\n        $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$c]) / $T)) & MAX;\n\n        if ($high > MAX) {\n            die \"high > MAX: $high > ${\\MAX}\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n\n                my $bit = $high >> (BITS - 1);\n                $enc .= $bit;\n\n                if ($uf_count > 0) {\n                    $enc .= join('', 1 - $bit) x $uf_count;\n                    $uf_count = 0;\n                }\n\n                $low <<= 1;\n                ($high <<= 1) |= 1;\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                ++$uf_count;\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n        }\n    }\n\n    $enc .= '0';\n    $enc .= '1';\n\n    while (length($enc) % 8 != 0) {\n        $enc .= '1';\n    }\n\n    return ($enc, \\%freq);\n}\n\nsub decode ($bits, $freq) {\n    open my $fh, '<:raw', \\$bits;\n\n    my ($cf, $T) = create_cfreq($freq);\n\n    my $dec  = '';\n    my $low  = 0;\n    my $high = MAX;\n    my $enc  = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS);\n\n    my @table;\n    foreach my $i (sort { $a <=> $b } keys %$freq) {\n        foreach my $j ($cf->[$i] .. $cf->[$i + 1] - 1) {\n            $table[$j] = $i;\n        }\n    }\n\n    my $EOF_SYMBOL = max(keys %$freq) // 0;\n\n    while (1) {\n\n        my $w  = $high - $low + 1;\n        my $ss = int((($T * ($enc - $low + 1)) - 1) / $w);\n\n        my $i = $table[$ss] // last;\n        last if ($i == $EOF_SYMBOL);\n\n        $dec .= chr($i);\n\n        $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX;\n        $low  = ($low + int(($w * $cf->[$i]) / $T)) & MAX;\n\n        if ($high > MAX) {\n            die \"error\";\n        }\n\n        if ($low >= $high) { die \"$low >= $high\" }\n\n        while (1) {\n\n            if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) {\n                ($high <<= 1) |= 1;\n                $low <<= 1;\n                ($enc <<= 1) |= (getc($fh) // 1);\n            }\n            elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) {\n                ($high <<= 1) |= (1 << (BITS - 1));\n                $high |= 1;\n                ($low <<= 1) &= ((1 << (BITS - 1)) - 1);\n                $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1);\n            }\n            else {\n                last;\n            }\n\n            $low  &= MAX;\n            $high &= MAX;\n            $enc  &= MAX;\n        }\n    }\n\n    return $dec;\n}\n\nmy $str = \"ABRACADABRA AND A VERY SAD SALAD\";\n\nif (@ARGV) {\n    if (-f $ARGV[0]) {\n        $str = do {\n            open my $fh, '<:raw', $ARGV[0];\n            local $/;\n            <$fh>;\n        };\n    }\n    else {\n        $str = $ARGV[0];\n    }\n}\n\nmy ($enc, $freq) = encode($str);\n\nsay $enc;\nsay \"Encoded bytes length: \", length($enc) / 8;\n\nmy $dec = decode($enc, $freq);\nsay $dec;\n$str eq $dec or die \"Decoding error: \", length($str), ' <=> ', length($dec);\n\n__END__\n0100110110111110100000000100000111110000110110011111000010110011011001000101100011011101001110000000010001111111\nEncoded bytes length: 14\nABRACADABRA AND A VERY SAD SALAD\n"
  },
  {
    "path": "Encoding/arithmetic_coding_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 11 February 2016\n# Edit: 31 July 2023\n# https://github.com/trizen\n\n# Arithmetic coding, implemented using big integers.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Arithmetic_coding#Arithmetic_coding_as_a_generalized_change_of_radix\n\nuse 5.036;\nuse Math::GMPz;\nuse List::Util qw(sum);\n\nsub cumulative_freq ($freq) {\n\n    my %cf;\n    my $total = 0;\n    foreach my $c (sort { $a <=> $b } keys %$freq) {\n        $cf{$c} = $total;\n        $total += $freq->{$c};\n    }\n\n    return %cf;\n}\n\nsub ac_encode ($bytes_arr) {\n\n    my @chars = @$bytes_arr;\n\n    # The frequency characters\n    my %freq;\n    ++$freq{$_} for @chars;\n\n    # Create the cumulative frequency table\n    my %cf = cumulative_freq(\\%freq);\n\n    # Limit and base\n    my $base = Math::GMPz->new(scalar @chars);\n\n    # Lower bound\n    my $L = Math::GMPz->new(0);\n\n    # Product of all frequencies\n    my $pf = Math::GMPz->new(1);\n\n    # Each term is multiplied by the product of the\n    # frequencies of all previously occurring symbols\n    foreach my $c (@chars) {\n        Math::GMPz::Rmpz_mul($L, $L, $base);\n        Math::GMPz::Rmpz_addmul_ui($L, $pf, $cf{$c});\n        Math::GMPz::Rmpz_mul_ui($pf, $pf, $freq{$c});\n    }\n\n    # Upper bound\n    my $U = $L + $pf;\n\n    # Compute the power for left shift\n    my $pow = Math::GMPz::Rmpz_sizeinbase($pf, 2) - 1;\n\n    # Set $enc to (U-1) divided by 2^pow\n    my $enc = ($U - 1) >> $pow;\n\n    # Remove any divisibility by 2\n    if ($enc > 0 and Math::GMPz::Rmpz_even_p($enc)) {\n        $pow += Math::GMPz::Rmpz_remove($enc, $enc, Math::GMPz->new(2));\n    }\n\n    my $bin = Math::GMPz::Rmpz_get_str($enc, 2);\n\n    return ($bin, $pow, \\%freq);\n}\n\nsub ac_decode ($bits, $pow2, $freq) {\n\n    # Decode the bits into an integer\n    my $enc = Math::GMPz->new($bits, 2);\n\n    $enc <<= $pow2;\n\n    my $base = sum(values %$freq) // 0;\n\n    if ($base == 0) {\n        return [];\n    }\n    elsif ($base == 1) {\n        return [keys %$freq];\n    }\n\n    # Create the cumulative frequency table\n    my %cf = cumulative_freq($freq);\n\n    # Create the dictionary\n    my %dict;\n    while (my ($k, $v) = each %cf) {\n        $dict{$v} = $k;\n    }\n\n    # Fill the gaps in the dictionary\n    my $lchar;\n    foreach my $i (0 .. $base - 1) {\n        if (exists $dict{$i}) {\n            $lchar = $dict{$i};\n        }\n        elsif (defined $lchar) {\n            $dict{$i} = $lchar;\n        }\n    }\n\n    my $div = Math::GMPz::Rmpz_init();\n\n    my @dec;\n\n    # Decode the input number\n    for (my $pow = Math::GMPz->new($base)**($base - 1) ; Math::GMPz::Rmpz_sgn($pow) > 0 ; Math::GMPz::Rmpz_tdiv_q_ui($pow, $pow, $base)) {\n\n        Math::GMPz::Rmpz_tdiv_q($div, $enc, $pow);\n\n        my $c  = $dict{$div};\n        my $fv = $freq->{$c};\n        my $cv = $cf{$c};\n\n        Math::GMPz::Rmpz_submul_ui($enc, $pow, $cv);\n        Math::GMPz::Rmpz_tdiv_q_ui($enc, $enc, $fv);\n\n        push @dec, $c;\n    }\n\n    return \\@dec;\n}\n\n#\n## Run some tests\n#\nforeach my $str (\n                 '',\n                 'a',\n                 'this is a message for you to encode and to decode correctly!',\n                 join('', 'a' .. 'z', 0 .. 9, 'A' .. 'Z', 0 .. 9),\n                 qw(DABDDB DABDDBBDDBA ABBDDD ABRACADABRA CoMpReSSeD Sidef Trizen google TOBEORNOTTOBEORTOBEORNOT),\n                 'In a positional numeral system the radix, or base, is numerically equal to a number of different symbols '\n                 . 'used to express the number. For example, in the decimal system the number of symbols is 10, namely 0, 1, 2, '\n                 . '3, 4, 5, 6, 7, 8, and 9. The radix is used to express any finite integer in a presumed multiplier in polynomial '\n                 . 'form. For example, the number 457 is actually 4×102 + 5×101 + 7×100, where base 10 is presumed but not shown explicitly.'\n  ) {\n\n    my @bytes = unpack('C*', $str);\n    my ($enc, $len, $freq) = ac_encode(\\@bytes);\n\n    my $dec_bytes = ac_decode($enc, $len, $freq);\n    my $dec       = pack('C*', @$dec_bytes);\n\n    say \"Encoded:  $enc\";\n    say \"Decoded:  $dec\";\n\n    if ($str ne $dec) {\n        die \"\\tHowever that is incorrect!\";\n    }\n\n    say \"-\" x 80;\n}\n"
  },
  {
    "path": "Encoding/ascii_encode_decode.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 25 July 2012\n# https://github.com/trizen\n\n# A simple ASCII encoder-decoder.\n\n# What's special is that you can delete words from the encoded text, and still be able to decode it.\n# You can also insert or append encoded words to an encoded string and decode it later.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub encode_decode ($$) {\n    my ($encode, $text) = @_;\n\n    my $i      = 1;\n    my $output = '';\n\n  LOOP_1: foreach my $c (map { ord } split //, $text) {\n        foreach my $o ([32, 121]) {\n            if ($c > $o->[0] && $c <= $o->[1]) {\n\n                my $ord =\n                    $encode\n                  ? $c + ($i % 2 ? $i : -$i)\n                  : $c - ($i % 2 ? $i : -$i);\n\n                if ($ord > $o->[1]) {\n                    $ord = $o->[0] + ($ord - $o->[1]);\n                }\n                elsif ($ord <= $o->[0]) {\n                    $ord = $o->[1] - ($o->[0] - $ord);\n                }\n                $output .= chr $ord;\n                ++$i;\n                next LOOP_1;\n            }\n        }\n        $output .= chr($c);\n        $i = 1;\n    }\n\n    return $output;\n}\n\nmy $enc = encode_decode(1, \"test\");\nmy $dec = encode_decode(0, $enc);\n\nsay \"Enc: \", $enc;\nsay \"Dec: \", $dec;\n\n# Encoding\nmy $encoded = encode_decode(1, \"Just another \") . encode_decode(1, \"Perl hacker,\");\n\n# Decoding\nmy $decoded = encode_decode(0, $encoded);\n\nsay $encoded;\nsay $decoded;\n"
  },
  {
    "path": "Encoding/binary_arithmetic_coding.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 07 May 2015\n# https://github.com/trizen\n\n# The binary arithmetic coding algorithm.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Arithmetic_coding\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::BigInt (try => 'GMP');\nuse Math::BigRat (try => 'GMP');\n\nsub asciibet {\n    map { chr } 0 .. 255;\n}\n\nsub cumulative_freq {\n    my ($freq, $sum) = @_;\n\n    my %cf;\n    my $total = 0;\n    foreach my $c (asciibet()) {\n        if (exists $freq->{$c}) {\n            $cf{$c} = $total;\n            $total += $freq->{$c};\n        }\n    }\n\n    return %cf;\n}\n\nsub mass_function {\n    my ($freq, $sum) = @_;\n\n    my %p;\n    $p{$_} = Math::BigRat->new($freq->{$_}) / $sum for keys %{$freq};\n\n    return %p;\n}\n\nsub arithmethic_coding {\n    my ($str) = @_;\n    my @chars = split(//, $str);\n\n    my %freq;\n    $freq{$_}++ for @chars;\n\n    my $len = @chars;\n    my %p   = mass_function(\\%freq, $len);\n    my %cf  = cumulative_freq(\\%p, $len);\n\n    my $pf = Math::BigRat->new(1);\n    my $L  = Math::BigRat->new(0);\n    foreach my $c (@chars) {\n        $L->badd($pf * $cf{$c});\n        $pf->bmul($p{$c});\n    }\n\n    my $U = $L + $pf;\n\n    my $big_two = Math::BigInt->new(2);\n    my $two_pow = Math::BigInt->new(1);\n    my $n       = Math::BigRat->new(0);\n\n    my $bin = '';\n    for (my $i = Math::BigInt->new(1) ; ($n < $L || $n >= $U) ; $i->binc) {\n        my $m = Math::BigRat->new(1)->bdiv($two_pow->bmul($big_two));\n\n        if ($n + $m < $U) {\n            $n += $m;\n            $bin .= '1';\n        }\n        else {\n            $bin .= '0';\n        }\n    }\n\n    return ($bin, $len, \\%freq);\n}\n\nsub arithmethic_decoding {\n    my ($enc, $len, $freq) = @_;\n\n    my $two_pow = Math::BigInt->new(1);\n    my $big_two = Math::BigInt->new(2);\n\n    my $line = Math::BigRat->new(0);\n\n    my @bin = split(//, $enc);\n    foreach my $i (0 .. $#bin) {\n        $line->badd(scalar Math::BigRat->new($bin[$i])->bdiv($two_pow->bmul($big_two)));\n    }\n\n    my %p  = mass_function($freq, $len);\n    my %cf = cumulative_freq(\\%p, $len);\n\n    my %df;\n    foreach my $k (keys %p) {\n        $df{$k} = $cf{$k} + $p{$k};\n    }\n\n    my $L = 0;\n    my $U = 1;\n\n    my $decoded = '';\n    my @chars   = sort { $p{$a} <=> $p{$b} or $a cmp $b } keys %p;\n\n    my $i = 0;\n    while (1) {\n        foreach my $c (@chars) {\n\n            my $w    = $U - $L;\n            my $low  = $L + $w * $cf{$c};\n            my $high = $L + $w * $df{$c};\n\n            if ($low <= $line and $line < $high) {\n                ($L, $U) = ($low, $high);\n                $decoded .= $c;\n                if (++$i == $len) {\n                    return $decoded;\n                }\n            }\n        }\n    }\n}\n\n#\n## Run some tests\n#\nforeach my $str (\n                 'this is a message for you to encode and to decode correctly!',\n                 join('', 'a' .. 'z', 0 .. 9, 'A' .. 'Z', 0 .. 9),\n                 qw(DABDDB DABDDBBDDBA ABBDDD ABRACADABRA CoMpReSSeD Sidef Trizen google TOBEORNOTTOBEORTOBEORNOT),\n                 'In a positional numeral system the radix, or base, is numerically equal to a number of different symbols '\n                 . 'used to express the number. For example, in the decimal system the number of symbols is 10, namely 0, 1, 2, '\n                 . '3, 4, 5, 6, 7, 8, and 9. The radix is used to express any finite integer in a presumed multiplier in polynomial '\n                 . 'form. For example, the number 457 is actually 4×102 + 5×101 + 7×100, where base 10 is presumed but not shown explicitly.'\n  ) {\n    my ($enc, $len, $freq) = arithmethic_coding($str);\n    my $dec = arithmethic_decoding($enc, $len, $freq);\n\n    say \"Encoded:  $enc\";\n    say \"Decoded:  $dec\";\n\n    if ($str ne $dec) {\n        die \"\\tHowever that is incorrect!\";\n    }\n\n    say \"-\" x 80;\n}\n"
  },
  {
    "path": "Encoding/binary_arithmetic_coding_anynum.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 07 May 2015\n# https://github.com/trizen\n\n# The binary arithmetic coding algorithm.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Arithmetic_coding\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum;\n\nsub asciibet {\n    map { chr } 0 .. 255;\n}\n\nsub cumulative_freq {\n    my ($freq, $sum) = @_;\n\n    my %cf;\n    my $total = 0;\n    foreach my $c (asciibet()) {\n        if (exists $freq->{$c}) {\n            $cf{$c} = $total;\n            $total += $freq->{$c};\n        }\n    }\n\n    return %cf;\n}\n\nsub mass_function {\n    my ($freq, $sum) = @_;\n\n    my %p;\n    $p{$_} = Math::AnyNum->new($freq->{$_}) / $sum for keys %{$freq};\n\n    return %p;\n}\n\nsub arithmethic_coding {\n    my ($str) = @_;\n    my @chars = split(//, $str);\n\n    my %freq;\n    $freq{$_}++ for @chars;\n\n    my $len = @chars;\n    my %p   = mass_function(\\%freq, $len);\n    my %cf  = cumulative_freq(\\%p, $len);\n\n    my $pf = Math::AnyNum->new(1);\n    my $L  = Math::AnyNum->new(0);\n\n    for my $c (@chars) {\n        $L  += $pf * $cf{$c};\n        $pf *= $p{$c};\n    }\n\n    my $U = $L + $pf;\n\n    my $t = Math::AnyNum->new(1);\n    my $n = Math::AnyNum->new(0);\n\n    my $bin = '';\n    while ($n < $L || $n >= $U) {\n        my $m = 1 / ($t <<= 1);\n\n        if ($n + $m < $U) {\n            $n += $m;\n            $bin .= '1';\n        }\n        else {\n            $bin .= '0';\n        }\n    }\n\n    return ($bin, $len, \\%freq);\n}\n\nsub arithmethic_decoding {\n    my ($enc, $len, $freq) = @_;\n\n    my $t    = Math::AnyNum->new(1);\n    my $line = Math::AnyNum->new(0);\n\n    my @bin = split(//, $enc);\n    foreach my $i (0 .. $#bin) {\n        $line += $bin[$i] / ($t <<= 1);\n    }\n\n    my %p  = mass_function($freq, $len);\n    my %cf = cumulative_freq(\\%p, $len);\n\n    my %df;\n    foreach my $k (keys %p) {\n        $df{$k} = $cf{$k} + $p{$k};\n    }\n\n    my $L = 0;\n    my $U = 1;\n\n    my $decoded = '';\n    my @chars   = sort { $p{$a} <=> $p{$b} or $a cmp $b } keys %p;\n\n    my $i = 0;\n    while (1) {\n        foreach my $c (@chars) {\n\n            my $w    = $U - $L;\n            my $low  = $L + $w * $cf{$c};\n            my $high = $L + $w * $df{$c};\n\n            if ($low <= $line and $line < $high) {\n                ($L, $U) = ($low, $high);\n                $decoded .= $c;\n                if (++$i == $len) {\n                    return $decoded;\n                }\n            }\n        }\n    }\n}\n\n#\n## Run some tests\n#\nforeach my $str (\n                 'this is a message for you to encode and to decode correctly!',\n                 join('', 'a' .. 'z', 0 .. 9, 'A' .. 'Z', 0 .. 9),\n                 qw(DABDDB DABDDBBDDBA ABBDDD ABRACADABRA CoMpReSSeD Sidef Trizen google TOBEORNOTTOBEORTOBEORNOT),\n                 'In a positional numeral system the radix, or base, is numerically equal to a number of different symbols '\n                 . 'used to express the number. For example, in the decimal system the number of symbols is 10, namely 0, 1, 2, '\n                 . '3, 4, 5, 6, 7, 8, and 9. The radix is used to express any finite integer in a presumed multiplier in polynomial '\n                 . 'form. For example, the number 457 is actually 4×102 + 5×101 + 7×100, where base 10 is presumed but not shown explicitly.'\n  ) {\n    my ($enc, $len, $freq) = arithmethic_coding($str);\n    my $dec = arithmethic_decoding($enc, $len, $freq);\n\n    say \"Encoded:  $enc\";\n    say \"Decoded:  $dec\";\n\n    if ($str ne $dec) {\n        die \"\\tHowever that is incorrect!\";\n    }\n\n    say \"-\" x 80;\n}\n"
  },
  {
    "path": "Encoding/binary_variable_length_run_encoding.pl",
    "content": "#!/usr/bin/perl\n\n# Implementation of the Variable Length Run Encoding, for a binary string consisting of only 0s and 1s.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 5 - Basic Techniques\n#   https://youtube.com/watch?v=TdFWb8mL5Gk\n\nuse 5.036;\n\nsub run_length ($arr) {\n\n    @$arr || return [];\n\n    my @result     = [$arr->[0], 1];\n    my $prev_value = $arr->[0];\n\n    foreach my $i (1 .. $#{$arr}) {\n\n        my $curr_value = $arr->[$i];\n\n        if ($curr_value eq $prev_value) {\n            ++$result[-1][1];\n        }\n        else {\n            push(@result, [$curr_value, 1]);\n        }\n\n        $prev_value = $curr_value;\n    }\n\n    return \\@result;\n}\n\nsub binary_vrl_encoding ($str) {\n\n    my @bits      = split(//, $str);\n    my $bitstring = $bits[0];\n\n    foreach my $rle (@{run_length(\\@bits)}) {\n        my ($c, $v) = @$rle;\n\n        if ($v == 1) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', $v - 1);\n            $bitstring .= join('', '1' x length($t), '0', substr($t, 1));\n        }\n    }\n\n    return $bitstring;\n}\n\nsub binary_vrl_decoding ($bitstring) {\n\n    open my $fh, '<:raw', \\$bitstring;\n\n    my $decoded = '';\n    my $bit     = getc($fh);\n\n    while (!eof($fh)) {\n\n        $decoded .= $bit;\n\n        my $bl = 0;\n        while (getc($fh) == 1) {\n            ++$bl;\n        }\n\n        if ($bl > 0) {\n            $decoded .= $bit x oct('0b1' . join('', map { getc($fh) } 1 .. $bl - 1));\n        }\n\n        $bit = ($bit eq '1' ? '0' : '1');\n    }\n\n    return $decoded;\n}\n\nmy $bitstring = \"101000010000000010000000100000000001001100010000000000000010010100000000000000001\";\n\nmy $enc = binary_vrl_encoding($bitstring);\nmy $dec = binary_vrl_decoding($enc);\n\nsay $enc;\nsay $dec;\n\n$dec eq $bitstring or die \"error\";\n\n__END__\n1000110101110110111010011110001010101100011110101010000111101110\n101000010000000010000000100000000001001100010000000000000010010100000000000000001\n"
  },
  {
    "path": "Encoding/binradix_arithmetic_coding.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 07 May 2015\n# https://github.com/trizen\n\n# The arithmetic coding algorithm (radix+binary).\n\n# See also:\n#   https://en.wikipedia.org/wiki/Arithmetic_coding#Arithmetic_coding_as_a_generalized_change_of_radix\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::BigInt (try => 'GMP');\nuse Math::BigRat (try => 'GMP');\n\nsub asciibet {\n    map { chr } 0 .. 255;\n}\n\nsub cumulative_freq {\n    my ($freq) = @_;\n\n    my %cf;\n    my $total = Math::BigInt->new(0);\n    foreach my $c (asciibet()) {\n        if (exists $freq->{$c}) {\n            $cf{$c} = $total;\n            $total += $freq->{$c};\n        }\n    }\n\n    return %cf;\n}\n\nsub arithmethic_coding {\n    my ($str) = @_;\n    my @chars = split(//, $str);\n\n    # The frequency characters\n    my %freq;\n    $freq{$_}++ for @chars;\n\n    # The cumulative frequency table\n    my %cf = cumulative_freq(\\%freq);\n\n    # Limit and base\n    my $base = scalar @chars;\n\n    # Lower bound\n    my $L = Math::BigInt->new(0);\n\n    # Product of all frequencies\n    my $pf = Math::BigInt->new(1);\n\n    # Each term is multiplied by the product of the\n    # frequencies of all previously occurring symbols\n    foreach my $c (@chars) {\n        $L->bmuladd($base, $cf{$c} * $pf);\n        $pf->bmul($freq{$c});\n    }\n\n    # Upper bound\n    my $U = $L + $pf;\n\n    my $len = $L->length;\n    $L = Math::BigRat->new(\"$L / \" . Math::BigInt->new(10)->bpow($len));\n    $U = Math::BigRat->new(\"$U / \" . Math::BigInt->new(10)->bpow($len));\n\n    my $big_two = Math::BigInt->new(2);\n    my $two_pow = Math::BigInt->new(1);\n    my $n       = Math::BigRat->new(0);\n\n    my $bin = '';\n    while ($n < $L || $n >= $U) {\n        my $m = Math::BigRat->new(1)->bdiv($two_pow->bmul($big_two));\n\n        if ($n + $m < $U) {\n            $n += $m;\n            $bin .= '1';\n        }\n        else {\n            $bin .= '0';\n        }\n    }\n\n    #~ say $L;\n    #~ say $U;\n\n    return ($bin, $len, \\%freq);\n}\n\nsub arithmethic_decoding {\n    my ($enc, $pow, $freq) = @_;\n\n    my $two_pow = Math::BigInt->new(1);\n    my $big_two = Math::BigInt->new(2);\n\n    my $line = Math::BigRat->new(0);\n\n    my @bin = split(//, $enc);\n    foreach my $i (0 .. $#bin) {\n        $line->badd(scalar Math::BigRat->new($bin[$i])->bdiv($two_pow->bmul($big_two)));\n    }\n\n    $enc = $line->bmul(Math::BigInt->new(10)->bpow($pow))->as_int;\n\n    my $base = Math::BigInt->new(0);\n    $base += $_ for values %{$freq};\n\n    # Create the cumulative frequency table\n    my %cf = cumulative_freq($freq);\n\n    # Create the dictionary\n    my %dict;\n    while (my ($k, $v) = each %cf) {\n        $dict{$v} = $k;\n    }\n\n    # Fill the gaps in the dictionary\n    my $lchar;\n    foreach my $i (0 .. $base - 1) {\n        if (exists $dict{$i}) {\n            $lchar = $dict{$i};\n        }\n        elsif (defined $lchar) {\n            $dict{$i} = $lchar;\n        }\n    }\n\n    # Decode the input number\n    my $decoded = '';\n    for (my $i = $base - 1 ; $i >= 0 ; $i--) {\n\n        my $pow = $base**$i;\n        my $div = ($enc / $pow);\n\n        my $c  = $dict{$div};\n        my $fv = $freq->{$c};\n        my $cv = $cf{$c};\n\n        my $rem = ($enc - $pow * $cv) / $fv;\n\n        #~ say \"$enc / $base^$i = $div ($c)\";\n        #~ say \"($enc - $base^$i * $cv) / $fv = $rem\\n\";\n\n        $enc = $rem;\n        $decoded .= $c;\n    }\n\n    # Return the decoded output\n    return $decoded;\n}\n\n#\n## Run some tests\n#\nforeach my $str (\n                 qw(DABDDB DABDDBBDDBA ABBDDD ABRACADABRA CoMpReSSeD Sidef Trizen google TOBEORNOTTOBEORTOBEORNOT),\n                 'In a positional numeral system the radix, or base, is numerically equal to a number of different symbols '\n                 . 'used to express the number. For example, in the decimal system the number of symbols is 10, namely 0, 1, 2, '\n                 . '3, 4, 5, 6, 7, 8, and 9. The radix is used to express any finite integer in a presumed multiplier in polynomial '\n                 . 'form. For example, the number 457 is actually 4×102 + 5×101 + 7×100, where base 10 is presumed but not shown explicitly.'\n  ) {\n    my ($enc, $pow, $freq) = arithmethic_coding($str);\n    my $dec = arithmethic_decoding($enc, $pow, $freq);\n\n    say \"Encoded:  $enc\";\n    say \"Decoded:  $dec\";\n\n    if ($str ne $dec) {\n        die \"\\tHowever that is incorrect!\";\n    }\n\n    say \"-\" x 80;\n}\n"
  },
  {
    "path": "Encoding/binradix_arithmetic_coding_anynum.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 07 May 2015\n# https://github.com/trizen\n\n# The arithmetic coding algorithm (radix+binary).\n\n# See also:\n#   https://en.wikipedia.org/wiki/Arithmetic_coding#Arithmetic_coding_as_a_generalized_change_of_radix\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(ipow ipow10 idiv);\n\nsub cumulative_freq {\n    my ($freq) = @_;\n\n    my %cf;\n    my $total = Math::AnyNum->new(0);\n    foreach my $c (sort keys %$freq) {\n        $cf{$c} = $total;\n        $total += $freq->{$c};\n    }\n\n    return %cf;\n}\n\nsub arithmethic_coding {\n    my ($str) = @_;\n    my @chars = split(//, $str);\n\n    # The frequency characters\n    my %freq;\n    $freq{$_}++ for @chars;\n\n    # The cumulative frequency table\n    my %cf = cumulative_freq(\\%freq);\n\n    # Limit and base\n    my $base = scalar @chars;\n\n    # Lower bound\n    my $L = Math::AnyNum->new(0);\n\n    # Product of all frequencies\n    my $pf = Math::AnyNum->new(1);\n\n    # Each term is multiplied by the product of the\n    # frequencies of all previously occurring symbols\n    for my $c (@chars) {\n        $L  *= $base;\n        $L  += $cf{$c} * $pf;\n        $pf *= $freq{$c};\n    }\n\n    # Upper bound\n    my $U = $L + $pf;\n\n    my $len = $L->length;\n\n    $L = Math::AnyNum->new(\"$L / \" . ipow10($len));\n    $U = Math::AnyNum->new(\"$U / \" . ipow10($len));\n\n    my $t = Math::AnyNum->new(1);\n    my $n = Math::AnyNum->new(0);\n\n    my $bin = '';\n    while ($n < $L || $n >= $U) {\n        my $m = 1 / ($t <<= 1);\n\n        if ($n + $m < $U) {\n            $n += $m;\n            $bin .= '1';\n        }\n        else {\n            $bin .= '0';\n        }\n    }\n\n    #~ say $L;\n    #~ say $U;\n\n    return ($bin, $len, \\%freq);\n}\n\nsub arithmethic_decoding {\n    my ($enc, $pow, $freq) = @_;\n\n    my $t    = Math::AnyNum->new(1);\n    my $line = Math::AnyNum->new(0);\n\n    my @bin = split(//, $enc);\n    foreach my $i (0 .. $#bin) {\n        $line += $bin[$i] / ($t <<= 1);\n    }\n\n    $enc = $line * ipow10($pow);\n\n    my $base = Math::AnyNum->new(0);\n    $base += $_ for values %{$freq};\n\n    # Create the cumulative frequency table\n    my %cf = cumulative_freq($freq);\n\n    # Create the dictionary\n    my %dict;\n    while (my ($k, $v) = each %cf) {\n        $dict{$v} = $k;\n    }\n\n    # Fill the gaps in the dictionary\n    my $lchar;\n    foreach my $i (0 .. $base - 1) {\n        if (exists $dict{$i}) {\n            $lchar = $dict{$i};\n        }\n        elsif (defined $lchar) {\n            $dict{$i} = $lchar;\n        }\n    }\n\n    # Decode the input number\n    my $decoded = '';\n    for (my $i = $base - 1 ; $i >= 0 ; $i--) {\n\n        my $pow = ipow($base, $i);\n        my $div = idiv($enc, $pow);\n\n        my $c  = $dict{$div};\n        my $fv = $freq->{$c};\n        my $cv = $cf{$c};\n\n        my $rem = ($enc - $pow * $cv) / $fv;\n\n        #~ say \"$enc / $base^$i = $div ($c)\";\n        #~ say \"($enc - $base^$i * $cv) / $fv = $rem\\n\";\n\n        $enc = $rem;\n        $decoded .= $c;\n    }\n\n    # Return the decoded output\n    return $decoded;\n}\n\n#\n## Run some tests\n#\nforeach my $str (\n                 qw(DABDDB DABDDBBDDBA ABBDDD ABRACADABRA CoMpReSSeD Sidef Trizen google TOBEORNOTTOBEORTOBEORNOT),\n                 'In a positional numeral system the radix, or base, is numerically equal to a number of different symbols '\n                 . 'used to express the number. For example, in the decimal system the number of symbols is 10, namely 0, 1, 2, '\n                 . '3, 4, 5, 6, 7, 8, and 9. The radix is used to express any finite integer in a presumed multiplier in polynomial '\n                 . 'form. For example, the number 457 is actually 4×102 + 5×101 + 7×100, where base 10 is presumed but not shown explicitly.'\n  ) {\n    my ($enc, $pow, $freq) = arithmethic_coding($str);\n    my $dec = arithmethic_decoding($enc, $pow, $freq);\n\n    say \"Encoded:  $enc\";\n    say \"Decoded:  $dec\";\n\n    if ($str ne $dec) {\n        die \"\\tHowever that is incorrect!\";\n    }\n\n    say \"-\" x 80;\n}\n"
  },
  {
    "path": "Encoding/burrows-wheeler_file_transform.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 14 June 2023\n# Edit: 17 September 2023\n# https://github.com/trizen\n\n# Apply the Burrows–Wheeler transform on a file.\n# https://rosettacode.org/wiki/Burrows–Wheeler_transform\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 12 - The Burrows-Wheeler Transform (BWT)\n#   https://youtube.com/watch?v=rQ7wwh4HRZM\n#\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\n\nuse Getopt::Std    qw(getopts);\nuse File::Basename qw(basename);\n\nuse constant {\n              LOOKAHEAD_LEN => 128,    # lower values are usually faster\n             };\n\nsub bwt_sort ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_sort($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion: O(n * log(n))\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    if ($idx > $#head) {\n        die \"Invalid bwt-index: $idx (must be <= $#head)\\n\";\n    }\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\ngetopts('dh', \\my %opts);\n\nif ($opts{h} or !@ARGV) {\n    die \"usage: $0 [-d] [input file] [output file]\\n\";\n}\n\nmy $input_file  = $ARGV[0];\nmy $output_file = $ARGV[1] // (basename($input_file) . ($opts{d} ? '.dec' : '.bw'));\n\nmy $content = do {\n    open my $fh, '<:raw', $input_file\n      or die \"Can't open file <<$input_file>> for reading: $!\";\n    local $/;\n    <$fh>;\n};\n\nif ($opts{d}) {    # decode mode\n    my $idx = unpack('N', substr($content, 0, 4, ''));\n    my $dec = bwt_decode($content, $idx);\n\n    open my $out_fh, '>:raw', $output_file\n      or die \"Can't open file <<$output_file>> for writing: $!\";\n\n    print $out_fh $dec;\n}\nelse {\n    my ($bwt, $idx) = bwt_encode($content);\n\n    open my $out_fh, '>:raw', $output_file\n      or die \"Can't open file <<$output_file>> for writing: $!\";\n\n    print $out_fh pack('N', $idx);\n    print $out_fh $bwt;\n}\n"
  },
  {
    "path": "Encoding/burrows-wheeler_transform-n-char_generalization.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 14 June 2023\n# Edit: 23 February 2024\n# https://github.com/trizen\n\n# Implementation of the Burrows–Wheeler transform, with fast inversion (n-character generalization).\n# https://rosettacode.org/wiki/Burrows–Wheeler_transform\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 12 - The Burrows-Wheeler Transform (BWT)\n#   https://youtube.com/watch?v=rQ7wwh4HRZM\n#\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\n\nsub bwt_cyclic ($s) {    # O(n) space (slowish)\n\n    my @cyclic = @$s;\n    my $len    = scalar(@cyclic);\n\n    my $rle = 1;\n    foreach my $i (1 .. $len - 1) {\n        if ($cyclic[$i] ne $cyclic[$i - 1]) {\n            $rle = 0;\n            last;\n        }\n    }\n\n    $rle && return [0 .. $len - 1];\n\n    [\n     sort {\n         my ($i, $j) = ($a, $b);\n\n         while ($cyclic[$i] eq $cyclic[$j]) {\n             $i %= $len if (++$i >= $len);\n             $j %= $len if (++$j >= $len);\n         }\n\n         $cyclic[$i] cmp $cyclic[$j];\n       } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_cyclic($s);\n    my @ret = map { $s->[$_ - 1] } @$bwt;\n\n    my $idx = 0;\n    foreach my $i (@$bwt) {\n        $i || last;\n        ++$idx;\n    }\n\n    return (\\@ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = @$bwt;\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\n#<<<\nmy @tests = (\n    \"banana\", \"appellee\", \"dogwood\", \"TOBEORNOTTOBEORTOBEORNOT\",\n    \"SIX.MIXED.PIXIES.SIFT.SIXTY.PIXIE.DUST.BOXES\", \"PINEAPPLE\",\n    \"\",\"a\",\"aa\",\"aabb\",\"aaaaaaaaaaaa\",\"aaaaaaaaaaaab\",\n    \"baaaaaaaaaaaa\",\"aaaaaabaaaaaa\",\"aaaaaaabaaaaa\",\n);\n#>>>\n\nforeach my $file (__FILE__, $^X) {\n    push @tests, do {\n        open my $fh, '<:raw', $file;\n        local $/;\n        <$fh>;\n    };\n}\n\nforeach my $str (@tests) {\n\n    my ($enc, $idx) = bwt_encode([unpack('(a3)*', $str)]);\n    my $dec = bwt_decode($enc, $idx);\n\n    if (length($str) < 1024) {\n        say \"BWT($dec) = ([@$enc], $idx)\";\n    }\n    $dec eq $str or die \"error: <<$dec>> != <<$str>>\";\n}\n\n__END__\nBWT(banana) = ([ban ana], 1)\nBWT(appellee) = ([ee ell app], 0)\nBWT(dogwood) = ([woo d dog], 1)\nBWT(TOBEORNOTTOBEORTOBEORNOT) = ([TOB TOB TOB EOR EOR EOR NOT NOT], 6)\nBWT(SIX.MIXED.PIXIES.SIFT.SIXTY.PIXIE.DUST.BOXES) = ([XIE SIX XTY XED IFT ST. BOX S.S XIE ES .DU .MI .PI .PI .SI], 9)\nBWT(PINEAPPLE) = ([PIN PLE EAP], 1)\nBWT() = ([], 0)\nBWT(a) = ([a], 0)\nBWT(aa) = ([aa], 0)\nBWT(aabb) = ([b aab], 0)\nBWT(aaaaaaaaaaaa) = ([aaa aaa aaa aaa], 0)\nBWT(aaaaaaaaaaaab) = ([b aaa aaa aaa aaa], 0)\nBWT(baaaaaaaaaaaa) = ([aaa aaa aaa baa a], 4)\nBWT(aaaaaabaaaaaa) = ([aaa baa a aaa aaa], 2)\nBWT(aaaaaaabaaaaa) = ([aaa aba a aaa aaa], 2)\n"
  },
  {
    "path": "Encoding/burrows-wheeler_transform.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 14 June 2023\n# https://github.com/trizen\n\n# Implementation of the Burrows–Wheeler transform, with fast inversion.\n# https://rosettacode.org/wiki/Burrows–Wheeler_transform\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 12 - The Burrows-Wheeler Transform (BWT)\n#   https://youtube.com/watch?v=rQ7wwh4HRZM\n#\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\n\nuse constant {\n              LOOKAHEAD_LEN => 512,    # lower values are faster (on average)\n             };\n\nsub bwt_quadratic ($s) {    # O(n^2) space (impractical)\n    [map { $_->[1] } sort { $a->[0] cmp $b->[0] } map { [substr($s, $_) . substr($s, 0, $_), $_] } 0 .. length($s) - 1];\n}\n\nsub bwt_simple ($s) {    # O(n) space (very slow)\n    [sort { (substr($s, $a) . substr($s, 0, $a)) cmp(substr($s, $b) . substr($s, 0, $b)) } 0 .. length($s) - 1];\n}\n\nsub bwt_cyclic ($s) {    # O(n) space (slow)\n\n    my @cyclic = split(//, $s);\n    my $len    = scalar(@cyclic);\n\n    my $rle = 1;\n    foreach my $i (1 .. $len - 1) {\n        if ($cyclic[$i] ne $cyclic[$i - 1]) {\n            $rle = 0;\n            last;\n        }\n    }\n\n    $rle && return [0 .. $len - 1];\n\n    [\n     sort {\n         my ($i, $j) = ($a, $b);\n\n         while ($cyclic[$i] eq $cyclic[$j]) {\n             $i %= $len if (++$i >= $len);\n             $j %= $len if (++$j >= $len);\n         }\n\n         $cyclic[$i] cmp $cyclic[$j];\n       } 0 .. $len - 1\n    ];\n}\n\nsub bwt_lookahead ($s) {    # O(n) space (moderately fast)\n    [\n     sort {\n         my $t = substr($s, $a, LOOKAHEAD_LEN);\n         my $u = substr($s, $b, LOOKAHEAD_LEN);\n\n         if (length($t) < LOOKAHEAD_LEN) {\n             $t .= substr($s, 0, ($a < LOOKAHEAD_LEN) ? $a : (LOOKAHEAD_LEN - length($t)));\n         }\n\n         if (length($u) < LOOKAHEAD_LEN) {\n             $u .= substr($s, 0, ($b < LOOKAHEAD_LEN) ? $b : (LOOKAHEAD_LEN - length($u)));\n         }\n\n         ($t cmp $u) || ((substr($s, $a) . substr($s, 0, $a)) cmp(substr($s, $b) . substr($s, 0, $b)))\n       } 0 .. length($s) - 1\n    ];\n}\n\nsub bwt_balanced ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n#<<<\n    [\n     map { $_->[1] }\n     sort {\n              ($a->[0] cmp $b->[0])\n           || ((substr($s, $a->[1]) . substr($s, 0, $a->[1])) cmp (substr($s, $b->[1]) . substr($s, 0, $b->[1])))\n     }\n     map {\n         my $t = substr($s, $_, LOOKAHEAD_LEN);\n\n         if (length($t) < LOOKAHEAD_LEN) {\n             $t .= substr($s, 0, ($_ < LOOKAHEAD_LEN) ? $_ : (LOOKAHEAD_LEN - length($t)));\n         }\n\n         [$t, $_]\n       } 0 .. length($s) - 1\n    ];\n#>>>\n}\n\nsub bwt_balanced_double ($s) {    # O(n * LOOKAHEAD_LEN) space (fast)\n#<<<\n    my $len      = length($s);\n    my $double_s = $s . $s;                  # Pre-compute doubled string\n\n    # Schwartzian transform with optimized sorting\n    return [\n        map  { $_->[1] }\n        sort {\n                ($a->[0] cmp $b->[0])\n             || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len))\n        }\n        map {\n            my $pos = $_;\n            my $end = $pos + LOOKAHEAD_LEN;\n\n            # Handle wraparound efficiently\n            my $t =\n              ($end <= $len)\n              ? substr($s,        $pos, LOOKAHEAD_LEN)\n              : substr($double_s, $pos, LOOKAHEAD_LEN);\n\n            [$t, $pos]\n          } 0 .. $len - 1\n    ];\n#>>>\n}\n\nsub bwt_encode ($s) {\n\n    #my $bwt = bwt_simple($s);\n    #my $bwt = bwt_quadratic($s);\n    #my $bwt = bwt_cyclic($s);\n    #my $bwt = bwt_lookahead($s);\n    #my $bwt = bwt_balanced($s);\n    my $bwt = bwt_balanced_double($s);\n\n    my $ret = '';\n    my $idx = 0;\n\n    my $i = 0;\n    foreach my $pos (@$bwt) {\n        $ret .= substr($s, $pos - 1, 1);\n        $idx = $i if !$pos;\n        ++$i;\n    }\n\n    return ($ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = split(//, $bwt);\n    my @head = sort @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my $dec = '';\n    my $i   = $idx;\n\n    for (1 .. scalar(@head)) {\n        $dec .= $head[$i];\n        $i = $table[$i];\n    }\n\n    return $dec;\n}\n\n#<<<\nmy @tests = (\n    \"banana\", \"appellee\", \"dogwood\", \"TOBEORNOTTOBEORTOBEORNOT\",\n    \"SIX.MIXED.PIXIES.SIFT.SIXTY.PIXIE.DUST.BOXES\", \"PINEAPPLE\",\n    \"\",\"a\",\"aa\",\"aabb\",\"aaaaaaaaaaaa\",\"aaaaaaaaaaaab\",\n    \"baaaaaaaaaaaa\",\"aaaaaabaaaaaa\",\"aaaaaaabaaaaa\",\n);\n#>>>\n\nforeach my $file (__FILE__, $^X) {\n    push @tests, do {\n        open my $fh, '<:raw', $file;\n        local $/;\n        <$fh>;\n    };\n}\n\nforeach my $str (@tests) {\n    my ($enc, $idx) = bwt_encode($str);\n    my $dec = bwt_decode($enc, $idx);\n    if (length($str) < 1024) {\n        say \"BWT($dec) = ($enc, $idx)\";\n    }\n    $dec eq $str or die \"error: <<$dec>> != <<$str>>\";\n}\n\n__END__\nBWT(banana) = (nnbaaa, 3)\nBWT(appellee) = (eelplepa, 0)\nBWT(dogwood) = (odoodwg, 1)\nBWT(TOBEORNOTTOBEORTOBEORNOT) = (OOOBBBRRTTTEEENNOOORTTOO, 20)\nBWT(SIX.MIXED.PIXIES.SIFT.SIXTY.PIXIE.DUST.BOXES) = (TEXYDST.E.IXIXIXXSSMPPS.B..E.S.EUSFXDIIOIIIT, 29)\nBWT(PINEAPPLE) = (ENLPPIEPA, 6)\n"
  },
  {
    "path": "Encoding/burrows-wheeler_transform_symbolic.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 14 June 2023\n# Edit: 18 March 2024\n# https://github.com/trizen\n\n# Implementation of the Burrows–Wheeler transform, generalized to work over any array of numerical symbols.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 12 - The Burrows-Wheeler Transform (BWT)\n#   https://youtube.com/watch?v=rQ7wwh4HRZM\n#\n#   Data Compression (Summer 2023) - Lecture 13 - BZip2\n#   https://youtube.com/watch?v=cvoZbBZ3M2A\n\nuse 5.036;\n\nsub bwt_cyclic ($s) {    # O(n) space (slowish)\n\n    my @cyclic = @$s;\n    my $len    = scalar(@cyclic);\n\n    my $rle = 1;\n    foreach my $i (1 .. $len - 1) {\n        if ($cyclic[$i] != $cyclic[$i - 1]) {\n            $rle = 0;\n            last;\n        }\n    }\n\n    $rle && return [0 .. $len - 1];\n\n    [\n     sort {\n         my ($i, $j) = ($a, $b);\n\n         while ($cyclic[$i] == $cyclic[$j]) {\n             $i %= $len if (++$i >= $len);\n             $j %= $len if (++$j >= $len);\n         }\n\n         $cyclic[$i] <=> $cyclic[$j];\n       } 0 .. $len - 1\n    ];\n}\n\nsub bwt_encode ($s) {\n\n    my $bwt = bwt_cyclic($s);\n    my @ret = map { $s->[$_ - 1] } @$bwt;\n\n    my $idx = 0;\n    foreach my $i (@$bwt) {\n        $i || last;\n        ++$idx;\n    }\n\n    return (\\@ret, $idx);\n}\n\nsub bwt_decode ($bwt, $idx) {    # fast inversion\n\n    my @tail = @$bwt;\n    my @head = sort { $a <=> $b } @tail;\n\n    my %indices;\n    foreach my $i (0 .. $#tail) {\n        push @{$indices{$tail[$i]}}, $i;\n    }\n\n    my @table;\n    foreach my $v (@head) {\n        push @table, shift(@{$indices{$v}});\n    }\n\n    my @dec;\n    my $i = $idx;\n\n    for (1 .. scalar(@head)) {\n        push @dec, $head[$i];\n        $i = $table[$i];\n    }\n\n    return \\@dec;\n}\n\n#<<<\nmy @tests = (\n    \"banana\", \"appellee\", \"dogwood\", \"TOBEORNOTTOBEORTOBEORNOT\",\n    \"SIX.MIXED.PIXIES.SIFT.SIXTY.PIXIE.DUST.BOXES\", \"PINEAPPLE\",\n    \"\",\"a\",\"aa\",\"aabb\",\"aaaaaaaaaaaa\",\"aaaaaaaaaaaab\",\n    \"baaaaaaaaaaaa\",\"aaaaaabaaaaaa\",\"aaaaaaabaaaaa\",\n);\n#>>>\n\nforeach my $file (__FILE__, $^X) {\n    push @tests, do {\n        open my $fh, '<:raw', $file;\n        local $/;\n        <$fh>;\n    };\n}\n\nforeach my $str (@tests) {\n\n    my ($enc, $idx) = bwt_encode([unpack('C*', $str)]);\n    my $dec = bwt_decode($enc, $idx);\n\n    if (length($str) < 1024) {\n        printf(\"BWT(%s) = (%s, %d)\\n\", pack('C*', @$dec), pack('C*', @$enc), $idx);\n    }\n    pack('C*', @$dec) eq $str or die sprintf(\"error: <<%s>> != <<%s>>\", pack('C*', @$dec), $str);\n}\n\n__END__\nBWT(banana) = (nnbaaa, 3)\nBWT(appellee) = (eelplepa, 0)\nBWT(dogwood) = (odoodwg, 1)\nBWT(TOBEORNOTTOBEORTOBEORNOT) = (OOOBBBRRTTTEEENNOOORTTOO, 20)\nBWT(SIX.MIXED.PIXIES.SIFT.SIXTY.PIXIE.DUST.BOXES) = (TEXYDST.E.IXIXIXXSSMPPS.B..E.S.EUSFXDIIOIIIT, 29)\nBWT(PINEAPPLE) = (ENLPPIEPA, 6)\nBWT() = (, 0)\nBWT(a) = (a, 0)\nBWT(aa) = (aa, 0)\nBWT(aabb) = (baba, 0)\nBWT(aaaaaaaaaaaa) = (aaaaaaaaaaaa, 0)\nBWT(aaaaaaaaaaaab) = (baaaaaaaaaaaa, 0)\nBWT(baaaaaaaaaaaa) = (baaaaaaaaaaaa, 12)\nBWT(aaaaaabaaaaaa) = (baaaaaaaaaaaa, 6)\nBWT(aaaaaaabaaaaa) = (baaaaaaaaaaaa, 5)\n"
  },
  {
    "path": "Encoding/delta_encoding_with_double-elias_coding.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 14 June 2023\n# https://github.com/trizen\n\n# Implementation of the Delta encoding scheme, combined with Elias gamma encoding, optimized for very large deltas.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 6 - Delta Compression and Prediction\n#   https://youtube.com/watch?v=-3H_eDbWNEU\n\nuse 5.036;\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub delta_encode ($integers) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', abs($d) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($str) {\n\n    open my $fh, '<:raw', \\$str;\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nmy @integers = map { int(rand($_)) } 1 .. 1000;\nmy $str      = delta_encode([@integers]);\n\nsay \"Encoded length: \", length($str);\nsay \"Rawdata length: \", length(join(' ', @integers));\n\nmy $decoded = delta_decode($str);\n\njoin(' ', @integers) eq join(' ', @$decoded) or die \"Decoding error\";\n\n{\n    open my $fh, '<:raw', __FILE__;\n    my $str     = do { local $/; <$fh> };\n    my $encoded = delta_encode([unpack('C*', $str)]);\n    my $decoded = delta_decode($encoded);\n    $str eq pack('C*', @$decoded) or die \"error\";\n}\n\n__END__\nEncoded length: 1763\nRawdata length: 3615\n"
  },
  {
    "path": "Encoding/delta_encoding_with_elias_coding.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 14 June 2023\n# https://github.com/trizen\n\n# Implementation of the Delta encoding scheme, combined with Elias gamma encoding, optimized for moderately large deltas.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 6 - Delta Compression and Prediction\n#   https://youtube.com/watch?v=-3H_eDbWNEU\n\nuse 5.036;\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub delta_encode ($integers) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($str) {\n\n    open my $fh, '<:raw', \\$str;\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nmy @integers = map { int(rand($_)) } 1 .. 1000;\nmy $str      = delta_encode([@integers]);\n\nsay \"Encoded length: \", length($str);\nsay \"Rawdata length: \", length(join(' ', @integers));\n\nmy $decoded = delta_decode($str);\n\njoin(' ', @integers) eq join(' ', @$decoded) or die \"Decoding error\";\n\n{\n    open my $fh, '<:raw', __FILE__;\n    my $str     = do { local $/; <$fh> };\n    my $encoded = delta_encode([unpack('C*', $str)]);\n    my $decoded = delta_decode($encoded);\n    $str eq pack('C*', @$decoded) or die \"error\";\n}\n\n__END__\nEncoded length: 1882\nRawdata length: 3626\n"
  },
  {
    "path": "Encoding/delta_encoding_with_unary_coding.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 13 June 2023\n# https://github.com/trizen\n\n# Implementation of the Delta encoding scheme, using unary coding.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 6 - Delta Compression and Prediction\n#   https://youtube.com/watch?v=-3H_eDbWNEU\n\nuse 5.036;\n\nsub delta_encode ($bytes) {\n\n    my @deltas;\n    my $prev = 0;\n\n    while (@$bytes) {\n        my $curr = shift(@$bytes);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (abs($d) - 1)) . '0';\n        }\n    }\n\n    return $bitstring;\n}\n\nsub delta_decode ($bitstring) {\n\n    my @bits = split(//, $bitstring);\n    my @deltas;\n\n    while (@bits) {\n        my $bit = shift(@bits);\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        else {\n            my $bit = shift(@bits);\n            my $n   = 1;\n            ++$n while (shift(@bits) eq '1');\n            push @deltas, ($bit eq '1' ? $n : -$n);\n        }\n    }\n\n    my @acc;\n    my $prev = 0;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nmy $str = \"TOBEORNOTTOBEORTOBEORNOT\";\n\nmy $encoded = delta_encode([unpack('C*', $str)]);\nmy $decoded = delta_decode($encoded);\n\nsay \"Encoded: \", \"$encoded\";\nsay \"Decoded: \", pack('C*', @$decoded);\n\n$str eq pack('C*', @$decoded) or die \"error\";\n\n{\n    open my $fh, '<:raw', __FILE__;\n    my $str     = do { local $/; <$fh> };\n    my $encoded = delta_encode([unpack('C*', $str)]);\n    my $decoded = delta_decode($encoded);\n    $str eq pack('C*', @$decoded) or die \"error\";\n}\n\n__END__\nEncoded: 111111111111111111111111111111111111111111111111111111111111111111111111111111111111101011110101111111111110111101111111111101111010111011011111100101111010111111111111011110111111111110111101110101111010111111111111011110111111111110111101011101101111110\nDecoded: TOBEORNOTTOBEORTOBEORNOT\n"
  },
  {
    "path": "Encoding/delta_rle_elias_encoding.pl",
    "content": "#!/usr/bin/perl\n\n# Implementation of Delta + Run-length + Elias coding, for encoding arbitrary integers.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 5 - Basic Techniques\n#   https://youtube.com/watch?v=TdFWb8mL5Gk\n#\n#   Data Compression (Summer 2023) - Lecture 6 - Delta Compression and Prediction\n#   https://youtube.com/watch?v=-3H_eDbWNEU\n\nuse 5.036;\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub run_length ($arr) {\n\n    @$arr || return [];\n\n    my @result     = [$arr->[0], 1];\n    my $prev_value = $arr->[0];\n\n    foreach my $i (1 .. $#{$arr}) {\n\n        my $curr_value = $arr->[$i];\n\n        if ($curr_value eq $prev_value) {\n            ++$result[-1][1];\n        }\n        else {\n            push(@result, [$curr_value, 1]);\n        }\n\n        $prev_value = $curr_value;\n    }\n\n    return \\@result;\n}\n\nsub DRE_encoding ($integers, $double = 0) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n    my $rle       = run_length(\\@deltas);\n\n    foreach my $cv (@$rle) {\n        my ($c, $v) = @$cv;\n\n        if ($c == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($c) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . (($c < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($c));\n            $bitstring .= '1' . (($c < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n\n        if ($v == 1) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', $v);\n            $bitstring .= join('', '1' x (length($t) - 1), '0', substr($t, 1));\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub DRE_decoding ($bitstring, $double = 0) {\n\n    open my $fh, '<:raw', \\$bitstring;\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer) // last;\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        elsif ($double) {\n            my $bit = read_bit($fh, \\$buffer);\n\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1);\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        my $bl = 0;\n        while (read_bit($fh, \\$buffer) == 1) {\n            ++$bl;\n        }\n\n        if ($bl > 0) {\n            my $run = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl)) - 1;\n            $k += $run;\n            push @deltas, ($deltas[-1]) x $run;\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nmy $str   = join('', 'a' x 13, 'b' x 14, 'c' x 10, 'd' x 3, 'e' x 1, 'f' x 1, 'g' x 4);\nmy @bytes = unpack('C*', $str);\n\nmy $enc = DRE_encoding(\\@bytes);\nmy $dec = pack('C*', @{DRE_decoding($enc)});\n\nsay unpack('B*', $enc);\nsay $dec;\n\n$dec eq $str or die \"error: $dec != $str\";\n\ndo {\n    my @integers = map { int(rand($_)) } 1 .. 1000;\n    my $str      = DRE_encoding([@integers], 1);\n\n    say \"Encoded length: \", length($str);\n    say \"Rawdata length: \", length(join(' ', @integers));\n\n    my $decoded = DRE_decoding($str, 1);\n\n    join(' ', @integers) eq join(' ', @$decoded) or die \"Decoding error\";\n\n    {\n        open my $fh, '<:raw', __FILE__;\n        my $str     = do { local $/; <$fh> };\n        my $encoded = DRE_encoding([unpack('C*', $str)], 1);\n        my $decoded = DRE_decoding($encoded, 1);\n        $str eq pack('C*', @$decoded) or die \"error\";\n    }\n  }\n\n__END__\nEncoded length: 1879\nRawdata length: 3628\n"
  },
  {
    "path": "Encoding/double-elias_gamma_encoding.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 14 June 2023\n# https://github.com/trizen\n\n# Implementation of the double-variant of the Elias gamma encoding scheme, optimized for large integers.\n\n# Reference:\n#   COMP526 7-5 SS7.4 Run length encoding\n#   https://youtube.com/watch?v=3jKLjmV1bL8\n\nuse 5.036;\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub elias_encoding ($integers) {\n\n    my $bitstring = '';\n    foreach my $k (scalar(@$integers), @$integers) {\n        if ($k == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', $k + 1);\n            my $l = length($t);\n            my $L = sprintf('%b', $l);\n            $bitstring .= ('1' x (length($L) - 1)) . '0' . substr($L, 1) . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub elias_decoding ($str) {\n\n    open my $fh, '<:raw', \\$str;\n\n    my @ints;\n    my $len    = 0;\n    my $buffer = '';\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n\n        my $bl = 0;\n        ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n        if ($bl > 0) {\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @ints, $int - 1;\n        }\n        else {\n            push @ints, 0;\n        }\n\n        if ($k == 0) {\n            $len = pop(@ints);\n        }\n    }\n\n    return \\@ints;\n}\n\nmy @integers = map { int(rand($_)) } 1 .. 1000;\nmy $str      = elias_encoding([@integers]);\n\nsay \"Encoded length: \", length($str);\nsay \"Rawdata length: \", length(join(' ', @integers));\n\nmy $decoded = elias_decoding($str);\n\njoin(' ', @integers) eq join(' ', @$decoded) or die \"Decoding error\";\n\n__END__\nEncoded length: 1631\nRawdata length: 3616\n"
  },
  {
    "path": "Encoding/elias_gamma_encoding.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 13 June 2023\n# https://github.com/trizen\n\n# Implementation of the Elias gamma encoding scheme.\n\n# Reference:\n#   COMP526 7-5 SS7.4 Run length encoding\n#   https://youtube.com/watch?v=3jKLjmV1bL8\n\nuse 5.036;\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub elias_encoding ($integers) {\n\n    my $bitstring = '';\n    foreach my $k (scalar(@$integers), @$integers) {\n        my $t = sprintf('%b', $k + 1);\n        $bitstring .= ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub elias_decoding ($str) {\n\n    open my $fh, '<:raw', \\$str;\n\n    my @ints;\n    my $len    = 0;\n    my $buffer = '';\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n\n        my $bl = 0;\n        ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n        push @ints, oct('0b' . '1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl)) - 1;\n\n        if ($k == 0) {\n            $len = pop(@ints);\n        }\n    }\n\n    return \\@ints;\n}\n\nmy @integers = map { int(rand($_)) } 1 .. 1000;\nmy $str      = elias_encoding([@integers]);\n\nsay \"Encoded length: \", length($str);\nsay \"Rawdata length: \", length(join(' ', @integers));\n\nmy $decoded = elias_decoding($str);\n\njoin(' ', @integers) eq join(' ', @$decoded) or die \"Decoding error\";\n\n__END__\nEncoded length: 1777\nRawdata length: 3594\n"
  },
  {
    "path": "Encoding/eyes_dropper.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Created on: 01 July 2011 (00:01 AM)\n# Latest edit on: 24 December 2011\n\n# Transforms a phrase in a Perl regex, using only punctuation characters.\n\nuse strict;\nuse warnings;\n\nuse List::Util ('shuffle');\n\nmy $phrase;\nmy @content;\nmy %chars_table;\n\nmy $quote       = 0;\nmy $compact     = 0;\nmy $exec_code   = 0;\nmy $eval_code   = 0;\nmy $brake_after = 8;\n\nmy @symbols = shuffle(qw'^ + \" * [ & | < ` / { > ; : ( ) ? - = } @ . ] $ _ % !', (',', '#'));\n\nforeach my $arg (@ARGV) {\n\n    if (-f $arg) {\n        open my $fh, '<', $arg or die $!;\n        sysread $fh, $phrase, -s $arg;\n        close $fh;\n        next;\n    }\n\n    if (substr($arg, 0, 1) eq '-') {\n\n        if ($arg =~ /^-+(?:h|help|usage|\\?)$/) {\n            usage();\n        }\n        elsif ($arg =~ /^-+exec(?:ute)?$/) {\n            $exec_code = 1;\n        }\n        elsif ($arg =~ /^-+e(?:val)?$/) {\n            $eval_code = 1;\n        }\n        elsif ($arg =~ /^-+e(?:val)?2$/) {\n            $eval_code = 2;\n        }\n        elsif ($arg =~ /^-+c(?:ompact)?$/) {\n            $compact = 1;\n        }\n        elsif ($arg =~ /^-+q(?:uote(?:meta)?)?$/) {\n            $quote = 1;\n        }\n        elsif ($arg =~ /^-+(\\d+)$/) {\n            $brake_after = $1;\n        }\n    }\n}\n\nunless (defined $phrase) {\n    my @words = grep { substr($_, 0, 1) ne '-' } @ARGV;\n    $phrase =\n      @words\n      ? join(' ', @words)\n      : 'Just another Perl hacker,';\n}\n\nsub usage {\n    print \"\nusage: $0 [...]\n\\noptions:\n         /my/file  : encode text from a file\n         -num      : newline before N chars (ex: -10)\n         -exec     : execute code (unix only)\n         -print    : print text using single quotes (default)\n         -eval     : eval code using single quotes\n         -eval2    : eval code using a code block\n         -compact  : compact code (not for files)\n         -quote    : quotemeta special characters\\n\\n\";\n    exit;\n}\n\nmy $char_to_quote = $quote ? qr/['\\\\{}]/ : qr/['\\\\]/;\nmy $action;\n\nif ($exec_code) {\n    $action = q[$x='/tmp/.x';open my $fh,\">$x\";system qq|perl $x| if print $fh];\n}\nelsif ($eval_code) {\n    $action = 'eval';\n}\nelse {\n    $action = 'print';\n}\n\nif ($compact) {\n    $phrase =~ s/~/\\\\~/g;\n    $phrase = \"$action q~$phrase\\n\";\n}\nelsif (defined $action and not $eval_code == 2) {\n    push @content, qq[use re 'eval';'\\n'=~('(?{'.];\n    $phrase = \"$action <<'Q_M';\\n$phrase\\nQ_M\\n\";\n}\nelsif (defined $action and $eval_code == 2) {\n    push @content, q[''=~('(?{'.];\n    $phrase = \"${action} {$phrase}\";\n}\n\nmy %memoize;\n\nLOOP_1: foreach my $letter (split(//, $phrase, 0)) {\n\n    if (exists $chars_table{$letter}) {\n        next LOOP_1 if $chars_table{$letter} eq 'Not found!';\n        $compact ? push(@content, $chars_table{$letter})\n          : (\n             ref($chars_table{$letter}) eq 'ARRAY' ? push(@content, \"('$chars_table{$letter}[0]'^'$chars_table{$letter}[1]').\")\n             : push(@content, $chars_table{$letter})\n            );\n        next LOOP_1;\n    }\n\n    foreach my $simb (@symbols) {\n        foreach my $chr (@symbols) {\n\n            next if exists $memoize{$simb . $chr};\n            next if exists $memoize{$chr . $simb};\n\n            ++$memoize{$simb . $chr};\n            ++$memoize{$chr . $simb};\n\n            $chars_table{$simb ^ $chr} = [$simb, $chr];\n\n            if (exists $chars_table{$letter}) {\n                if ($compact) {\n                    push @content, [$simb, $chr];\n                    next LOOP_1;\n                }\n                else {\n                    push @content, \"('${simb}'^'${chr}').\";\n                    next LOOP_1;\n                }\n            }\n        }\n    }\n\n    if (not $compact) {\n        $letter = quotemeta $letter if $letter =~ /$char_to_quote/o;\n        push @content, \"('${letter}').\";\n        $chars_table{$letter} = \"('${letter}').\";\n    }\n    else {\n        $chars_table{$letter} = 'Not found!';\n    }\n}\n\nif ($compact) {\n    print q[''=~('(?{'.('], (map { $content[$_][0] } 0 .. $#content), q['^'], (map { $content[$_][1] } 0 .. $#content), q[').'~})');], \"\\n\";\n}\nelse {\n    for (my $i = $brake_after - 1 ; $i <= $#content ; $i += $brake_after) {\n        splice @content, $i, 0, \"\\n\";\n    }\n    print @content, \"'})');\\n\";\n}\n"
  },
  {
    "path": "Encoding/fibonacci_coding.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 19 March 2024\n# https://github.com/trizen\n\n# Implementation of the Fibonacci coding method.\n\n# References:\n#   Information Retrieval WS 17/18, Lecture 4: Compression, Codes, Entropy\n#   https://youtube.com/watch?v=A_F94FV21Ek\n#\n#   Fibonacci coding\n#   https://en.wikipedia.org/wiki/Fibonacci_coding\n\nuse 5.036;\nuse List::Util qw(shuffle);\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub fibonacci_coding ($symbols) {\n\n    my $bitstring = '';\n\n    foreach my $n (@$symbols) {\n        my ($f1, $f2, $f3) = (0, 1, 1);\n        my ($rn, $s, $k) = ($n, '', 2);\n        for (; $f3 <= $rn ; ++$k) {\n            ($f1, $f2, $f3) = ($f2, $f3, $f2 + $f3);\n        }\n        foreach my $i (1 .. $k - 2) {\n            ($f3, $f2, $f1) = ($f2, $f1, $f2 - $f1);\n            if ($f3 <= $rn) {\n                $rn -= $f3;\n                $s .= '1';\n            }\n            else {\n                $s .= '0';\n            }\n        }\n        $bitstring .= reverse($s) . '1';\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub bsearch_le ($left, $right, $callback) {\n\n    my ($mid, $cmp);\n\n    for (; ;) {\n\n        $mid = int(($left + $right) / 2);\n        $cmp = $callback->($mid) || return $mid;\n\n        if ($cmp < 0) {\n            $left = $mid + 1;\n            $left > $right and last;\n        }\n        else {\n            $right = $mid - 1;\n\n            if ($left > $right) {\n                $mid -= 1;\n                last;\n            }\n        }\n    }\n\n    return $mid;\n}\n\n{\n    my @FIB = (0, 1);\n\n    sub find_fibonacci ($n) {\n\n        if ($n == 1) {\n            return (2, 0, 1, 1);\n        }\n\n        if ($n >= $FIB[-1]) {\n            my ($f1, $f2) = ($FIB[-2], $FIB[-1]);\n            while (1) {\n                ($f1, $f2) = ($f2, $f1 + $f2);\n                push @FIB, $f2;\n                last if ($f2 >= $n);\n            }\n        }\n\n        my $k = bsearch_le(0, $#FIB, sub ($k) { $FIB[$k] <=> $n });\n        return ($k, $FIB[$k - 1], $FIB[$k], $FIB[$k + 1]);\n    }\n}\n\nsub fibonacci_coding_cached ($symbols) {\n\n    my $bitstring = '';\n\n    foreach my $n (@$symbols) {\n        my ($rn, $s) = ($n, '');\n        my ($k, $f1, $f2, $f3) = find_fibonacci($n);\n        foreach my $i (1 .. $k - 1) {\n            ($f3, $f2, $f1) = ($f2, $f1, $f2 - $f1);\n            if ($f3 <= $rn) {\n                $rn -= $f3;\n                $s .= '1';\n            }\n            else {\n                $s .= '0';\n            }\n        }\n        $bitstring .= reverse($s) . '1';\n    }\n\n    return pack('B*', $bitstring);\n}\n\nsub fibonacci_decoding ($str) {\n\n    open my $fh, '<:raw', \\$str;\n\n    my @symbols;\n\n    my $enc      = '';\n    my $prev_bit = '0';\n    my $buffer   = '';\n\n    while (1) {\n        my $bit = read_bit($fh, \\$buffer) // last;\n        if ($bit eq '1' and $prev_bit eq '1') {\n            my ($value, $f1, $f2) = (0, 1, 1);\n            foreach my $bit (split //, $enc) {\n                $value += $f2 if $bit;\n                ($f1, $f2) = ($f2, $f1 + $f2);\n            }\n            push @symbols, $value;\n            $enc      = '';\n            $prev_bit = '0';\n        }\n        else {\n            $enc .= $bit;\n            $prev_bit = $bit;\n        }\n    }\n\n    return \\@symbols;\n}\n\nmy @integers = shuffle(grep { $_ > 0 } map { int(rand($_)) } 1 .. 1000);\nmy $str      = fibonacci_coding([@integers]);\nmy $str2     = fibonacci_coding_cached([@integers]);\n\nsay \"Encoded length: \", length($str);\nsay \"Rawdata length: \", length(join(' ', @integers));\n\nmy $decoded = fibonacci_decoding($str);\n\n$str eq $str2                                or die \"Encoding error\";\njoin(' ', @integers) eq join(' ', @$decoded) or die \"Decoding error\";\n\n__END__\nEncoded length: 1428\nRawdata length: 3608\n"
  },
  {
    "path": "Encoding/huffman_coding.pl",
    "content": "#!/usr/bin/perl\n\n# https://rosettacode.org/wiki/Huffman_coding#Perl\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0];\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for (0, 1) }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree ($bytes) {\n    my (%freq, @nodes);\n\n    ++$freq{$_} for @$bytes;\n    @nodes = map { [$_, $freq{$_}] } sort { $a <=> $b } keys %freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub encode ($bytes, $dict) {\n    join('', map { $dict->{$_} // die(\"bad char $_\") } @$bytes);\n}\n\nsub decode ($str, $dict) {\n    my ($seg, @out) = (\"\");\n\n    # append to current segment until it's in the dictionary\n    foreach my $bit (split('', $str)) {\n        $seg .= $bit;\n        my $x = $dict->{$seg} // next;\n        push @out, $x;\n        $seg = '';\n    }\n\n    die \"bad code\" if length($seg);\n    return \\@out;\n}\n\nmy $txt   = 'this is an example for huffman encoding';\nmy @bytes = unpack('C*', $txt);\nmy ($h, $rev_h) = mktree(\\@bytes);\nfor (keys %$h) { printf(\"%3d: %s\\n\", $_, $h->{$_}) }\n\nmy $enc = encode(\\@bytes, $h);\nsay $enc;\n\nmy $dec = decode($enc, $rev_h);\nsay pack('C*', @$dec);\n"
  },
  {
    "path": "Encoding/int2bytes.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Șuteu \"Trizen\" Daniel\n# License: GPLv3\n# Date: 18 August 2013\n# https://trizenx.blogspot.com\n\n# Get all the shortest possible combinations of byte values for a large integer.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse List::Util qw(min);\n\nsub _make_map {\n    my ($int) = @_;\n\n    my @groups = ([], [], []);\n    for my $i (1 .. 3) {\n        foreach my $j (0 .. length($int) - $i) {\n            $i > 1 && substr($int, $j, 1) == 0 && next;\n            (my $num = substr($int, $j, $i)) > 255 && next;\n            $groups[$i - 1][$j] = $num;\n        }\n    }\n\n    my @map = [[]];\n    for (my $j = 0 ; $j <= $#{$groups[0]} ; $j++) {\n        for (my $i = $j ; $i <= $#{$groups[0]} ; $i++) {\n            if (defined($groups[2][$i])) {\n                push @{$map[$j][$j]}, $groups[2][$i];\n                $i += 2;\n            }\n            elsif (defined($groups[1][$i])) {\n                push @{$map[$j][$j]}, $groups[1][$i];\n                $i += 1;\n            }\n            else {\n                push @{$map[$j][$j]}, $groups[0][$i];\n            }\n        }\n    }\n\n    return \\@map;\n}\n\nsub int2bytes {\n    my ($int) = @_;\n\n    my $data = _make_map($int);\n\n    my @nums;\n    foreach my $arr (@{$data}) {\n        for my $i (0 .. $#{$arr}) {\n            if (ref($arr->[$i]) eq 'ARRAY') {\n                my $head = _make_map(substr($int, 0, $i));\n                push @nums, [@{$head->[0][0]}, @{$arr->[$i]}];\n            }\n        }\n    }\n\n    my $min   = min(map { $#{$_} } @nums);\n    my @bytes = do {\n        my %seen;\n        grep { !$seen{join(' ', @{$_})}++ } grep { $#{$_} == $min } @nums;\n    };\n\n    return \\@bytes;\n}\n\n#\n## MAIN\n#\n\nmy $bigint = shift() // '8379776984727378713267797976';\nmy $array  = int2bytes($bigint);\n\nforeach my $byte_seq (@{$array}) {\n    say \"@{$byte_seq}\";\n    say map { chr } @{$byte_seq};\n    print \"\\n\";\n}\n"
  },
  {
    "path": "Encoding/integers_binary_encoding.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 23 March 2023\n# https://github.com/trizen\n\n# Encode and decode a random list of integers into a binary string, using increasing fixed-width segments.\n\nuse 5.036;\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub encode_integers ($integers) {\n\n    my @counts;\n    my $count           = 0;\n    my $bits_width      = 1;\n    my $bits_max_symbol = 1 << $bits_width;\n    my $processed_len   = 0;\n\n    foreach my $k (@$integers) {\n        while ($k >= $bits_max_symbol) {\n\n            if ($count > 0) {\n                push @counts, [$bits_width, $count];\n                $processed_len += $count;\n            }\n\n            $count = 0;\n            $bits_max_symbol *= 2;\n            $bits_width      += 1;\n        }\n        ++$count;\n    }\n\n    push @counts, grep { $_->[1] > 0 } [$bits_width, scalar(@$integers) - $processed_len];\n\n    my $compressed = chr(scalar @counts);\n\n    foreach my $pair (@counts) {\n        my ($blen, $len) = @$pair;\n        $compressed .= chr($blen);\n        $compressed .= pack('N', $len);\n    }\n\n    my $bits = '';\n    foreach my $pair (@counts) {\n        my ($blen, $len) = @$pair;\n        foreach my $symbol (splice(@$integers, 0, $len)) {\n            $bits .= sprintf(\"%0*b\", $blen, $symbol);\n        }\n    }\n\n    $compressed .= pack('B*', $bits);\n    return $compressed;\n}\n\nsub decode_integers ($str) {\n\n    open my $fh, '<:raw', \\$str;\n\n    my $count_len = ord(getc($fh));\n\n    my @counts;\n    my $bits_len = 0;\n\n    for (1 .. $count_len) {\n        my $blen = ord(getc($fh));\n        my $len  = unpack('N', join('', map { getc($fh) } 1 .. 4));\n        push @counts, [$blen + 0, $len + 0];\n        $bits_len += $blen * $len;\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @chunks;\n    foreach my $pair (@counts) {\n        my ($blen, $len) = @$pair;\n        foreach my $chunk (unpack(sprintf('(a%d)*', $blen), substr($bits, 0, $blen * $len, ''))) {\n            push @chunks, oct('0b' . $chunk);\n        }\n    }\n\n    return \\@chunks;\n}\n\nmy @integers = map { int(rand($_)) } 1 .. 1000;\nmy $str      = encode_integers([@integers]);\n\nsay \"Encoded length: \", length($str);\nsay \"Rawdata length: \", length(join(' ', @integers));\n\nmy $decoded = decode_integers($str);\n\njoin(' ', @integers) eq join(' ', @$decoded) or die \"Decoding error\";\n\n__END__\nEncoded length: 1168\nRawdata length: 3625\n"
  },
  {
    "path": "Encoding/integers_binary_encoding_with_delta_coding.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 23 March 2023\n# Edit: 13 June 2023\n# https://github.com/trizen\n\n# Encode and decode a random list of integers into a binary string, using increasing fixed-width segments.\n\nuse 5.036;\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\nsub encode_integers ($integers) {\n\n    my @counts;\n    my $count           = 0;\n    my $bits_width      = 1;\n    my $bits_max_symbol = 1 << $bits_width;\n    my $processed_len   = 0;\n\n    foreach my $k (@$integers) {\n        while ($k >= $bits_max_symbol) {\n\n            if ($count > 0) {\n                push @counts, [$bits_width, $count];\n                $processed_len += $count;\n            }\n\n            $count = 0;\n            $bits_max_symbol *= 2;\n            $bits_width      += 1;\n        }\n        ++$count;\n    }\n\n    push @counts, grep { $_->[1] > 0 } [$bits_width, scalar(@$integers) - $processed_len];\n\n    my $compressed = delta_encode([(map { $_->[0] } @counts), (map { $_->[1] } @counts)]);\n\n    my $bits = '';\n    foreach my $pair (@counts) {\n        my ($blen, $len) = @$pair;\n        foreach my $symbol (splice(@$integers, 0, $len)) {\n            $bits .= sprintf(\"%0*b\", $blen, $symbol);\n        }\n    }\n\n    $compressed .= pack('B*', $bits);\n    return $compressed;\n}\n\nsub decode_integers ($str) {\n\n    open my $fh, '<:raw', \\$str;\n\n    my $ints = delta_decode($fh);\n    my $half = scalar(@$ints) >> 1;\n\n    my @counts;\n    foreach my $i (0 .. ($half - 1)) {\n        push @counts, [$ints->[$i], $ints->[$half + $i]];\n    }\n\n    my $bits_len = 0;\n\n    foreach my $pair (@counts) {\n        my ($blen, $len) = @$pair;\n        $bits_len += $blen * $len;\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @integers;\n    foreach my $pair (@counts) {\n        my ($blen, $len) = @$pair;\n        foreach my $chunk (unpack(sprintf('(a%d)*', $blen), substr($bits, 0, $blen * $len, ''))) {\n            push @integers, oct('0b' . $chunk);\n        }\n    }\n\n    return \\@integers;\n}\n\nmy @integers = map { int(rand($_)) } 1 .. 1000;\nmy $str      = encode_integers([@integers]);\n\nsay \"Encoded length: \", length($str);\nsay \"Rawdata length: \", length(join(' ', @integers));\n\nmy $decoded = decode_integers($str);\n\njoin(' ', @integers) eq join(' ', @$decoded) or die \"Decoding error\";\n\n__END__\nEncoded length: 1133\nRawdata length: 3633\n"
  },
  {
    "path": "Encoding/integers_binary_encoding_with_huffman_coding.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 10 June 2023\n# https://github.com/trizen\n\n# Encode and decode a random list of integers into a binary string, using a DEFLATE-like approach + Huffman coding.\n\nuse 5.036;\nuse List::Util qw(max shuffle);\n\nuse constant {MAX_INT => 0b11111111111111111111111111111111};\n\n# [distance value, offset bits]\nmy @DISTANCE_SYMBOLS = (map { [$_, 0] } 0 .. 4);\n\nuntil ($DISTANCE_SYMBOLS[-1][0] > MAX_INT) {\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1];\n    push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]];\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub read_bits ($fh, $bits_len) {\n\n    my $data = '';\n    read($fh, $data, $bits_len >> 3);\n    $data = unpack('B*', $data);\n\n    while (length($data) < $bits_len) {\n        $data .= unpack('B*', getc($fh) // return undef);\n    }\n\n    if (length($data) > $bits_len) {\n        $data = substr($data, 0, $bits_len);\n    }\n\n    return $data;\n}\n\nsub delta_encode ($integers) {\n\n    my @deltas;\n    my $prev = 0;\n\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($fh) {\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    return \\@acc;\n}\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    join('', @{$dict}{@$bytes});\n}\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1}/gr;    # very fast\n}\n\nsub create_huffman_entry ($bytes, $out_fh) {\n\n    my %freq;\n    ++$freq{$_} for @$bytes;\n\n    my ($h, $rev_h) = mktree_from_freq(\\%freq);\n    my $enc = huffman_encode($bytes, $h);\n\n    my $max_symbol = max(keys %freq) // 0;\n\n    my @freqs;\n    foreach my $i (0 .. $max_symbol) {\n        push @freqs, $freq{$i} // 0;\n    }\n\n    print $out_fh delta_encode(\\@freqs);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n}\n\nsub decode_huffman_entry ($fh) {\n\n    my @freqs = @{delta_decode($fh)};\n\n    my %freq;\n    foreach my $i (0 .. $#freqs) {\n        if ($freqs[$i]) {\n            $freq{$i} = $freqs[$i];\n        }\n    }\n\n    my (undef, $rev_dict) = mktree_from_freq(\\%freq);\n\n    foreach my $k (keys %$rev_dict) {\n        $rev_dict->{$k} = chr($rev_dict->{$k});\n    }\n\n    my $enc_len = unpack('N', join('', map { getc($fh) } 1 .. 4));\n\n    if ($enc_len > 0) {\n        return huffman_decode(read_bits($fh, $enc_len), $rev_dict);\n    }\n\n    return '';\n}\n\nsub encode_integers_deflate_like ($integers) {\n\n    my @symbols;\n    my $offset_bits = '';\n\n    foreach my $dist (@$integers) {\n        foreach my $i (0 .. $#DISTANCE_SYMBOLS) {\n            if ($DISTANCE_SYMBOLS[$i][0] > $dist) {\n                push @symbols, $i - 1;\n\n                if ($DISTANCE_SYMBOLS[$i - 1][1] > 0) {\n                    $offset_bits .= sprintf('%0*b', $DISTANCE_SYMBOLS[$i - 1][1], $dist - $DISTANCE_SYMBOLS[$i - 1][0]);\n                }\n                last;\n            }\n        }\n    }\n\n    my $str = '';\n    open(my $out_fh, '>:raw', \\$str);\n    create_huffman_entry(\\@symbols, $out_fh);\n    print $out_fh pack('B*', $offset_bits);\n    return $str;\n}\n\nsub decode_integers_deflate_like ($str) {\n\n    open(my $fh, '<:raw', \\$str);\n\n    my @symbols  = unpack('C*', decode_huffman_entry($fh));\n    my $bits_len = 0;\n\n    foreach my $i (@symbols) {\n        $bits_len += $DISTANCE_SYMBOLS[$i][1];\n    }\n\n    my $bits = read_bits($fh, $bits_len);\n\n    my @distances;\n    foreach my $i (@symbols) {\n        push @distances, $DISTANCE_SYMBOLS[$i][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$i][1], ''));\n    }\n\n    return \\@distances;\n}\n\nmy @integers = shuffle(map { int(rand($_)) } 1 .. 1000);\nmy $str      = encode_integers_deflate_like([@integers]);\n\nsay \"Encoded length: \", length($str);\nsay \"Rawdata length: \", length(join(' ', @integers));\n\nmy $decoded = decode_integers_deflate_like($str);\n\njoin(' ', @integers) eq join(' ', @$decoded) or die \"Decoding error\";\n\n__END__\nEncoded length: 1196\nRawdata length: 3590\n"
  },
  {
    "path": "Encoding/jpeg_transform.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 21 December 2023\n# https://github.com/trizen\n\n# Apply the irreversible JPEG transform on arbitrary data. (lossy transform)\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse GD           qw();\nuse Getopt::Long qw(GetOptions);\nuse experimental qw(signatures);\n\nGD::Image->trueColor(1);\n\nbinmode(STDIN,  ':raw');\nbinmode(STDOUT, ':raw');\n\nsub encode_data ($data) {\n\n    my @bytes = unpack(\"C*\", $data);\n\n    my $c      = 1 + int(scalar(@bytes) / 3);\n    my $width  = int(sqrt($c));\n    my $height = int($c / $width) + 1;\n\n    say STDERR \":: Image size: $width x $height\";\n\n    my $image = GD::Image->new($width, $height)\n      or die \"Can't create image\";\n\n    my $size = scalar(@bytes);\n\n  OUTER: foreach my $y (0 .. $height - 1) {\n        foreach my $x (0 .. $width - 1) {\n            if ($size > 0) {\n                my $index = $image->colorResolve(shift(@bytes) // 0, shift(@bytes) // 0, shift(@bytes) // 0);\n                $image->setPixel($x, $y, $index);\n                $size -= 3;\n            }\n            else {\n                last OUTER;\n            }\n        }\n    }\n\n    return $image;\n}\n\nsub decode_data ($img_data, $length) {\n\n    my $image = GD::Image->new($img_data)\n      or die \"Can't read image: $!\";\n\n    my ($width, $height) = $image->getBounds();\n\n    my $data = '';\n    my $size = 0;\n\n  OUTER: foreach my $y (0 .. $height - 1) {\n        foreach my $x (0 .. $width - 1) {\n            my $index = $image->getPixel($x, $y);\n            if ($size < $length) {\n                my ($red, $green, $blue) = $image->rgb($index);\n                $data .= pack('C3', $red, $green, $blue);\n                $size += 3;\n            }\n            else {\n                last OUTER;\n            }\n        }\n    }\n\n    while (length($data) > $length) {\n        chop $data;\n    }\n\n    return $data;\n}\n\nmy $quality    = 100;\nmy $save_image = undef;\n\nsub help ($exit_code = 0) {\n    print <<\"EOT\";\nusage: $0 [options] [input] [output]\n\noptions:\n\n    -q  --quality=i    : quality level in range 0-100 (default: $quality)\n    -s  --save-image=s : save the JPEG image to a given filename\n\nexample:\n\n    perl $0 input.txt transformed.txt\nEOT\n\n    exit($exit_code);\n}\n\nGetOptions(\n           's|save-image=s' => \\$save_image,\n           'q|quality=i'    => \\$quality,\n           \"h|help\"         => sub { help(0) },\n          )\n  or die(\"Error in command line arguments\\n\");\n\nmy $data_file   = shift(@ARGV) // help(2);\nmy $output_file = shift(@ARGV);\n\nmy $data = do {\n    open my $fh, '<:raw', $data_file\n      or die \"Can't open file <<$data_file>> for reading: $!\";\n    local $/;\n    <$fh>;\n};\n\nmy $img  = encode_data($data);\nmy $jpeg = $img->jpeg($quality);\n\nif (defined($save_image)) {\n    open my $fh, '>:raw', $save_image\n      or die \"Can't open file <<$save_image>> for writing: $!\";\n    print $fh $jpeg;\n    close $fh;\n}\n\nmy $transformed = decode_data($jpeg, length($data));\n\nif (length($transformed) != length($data)) {\n    die sprintf(\"Failed: len(T) = %d != len(D) = %d\\n\", length($transformed), length($data));\n}\n\nif (defined($output_file)) {\n    open my $fh, '>:raw', $output_file\n      or die \"Can't open file <<$output_file>> for writing: $!\";\n    print $fh $transformed;\n    close $fh;\n}\nelse {\n    print $transformed;\n}\n"
  },
  {
    "path": "Encoding/length_encoder.pl",
    "content": "#!?usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 04 May 2015\n# Website: https://github.com/trizen\n\n# A very basic length encoder\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Data::Dump qw(pp);\n\n# produce encode and decode dictionary from a tree\nsub walk {\n    my ($node, $code, $h) = @_;\n\n    my $c = $node->[0];\n    if (ref $c) { walk($c->[$_], $code . $_, $h) for 0, 1 }\n    else        { $h->{$c} = $code }\n\n    $h;\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree {\n    my %freq = @_;\n\n    my @nodes = map { [$_, $freq{$_}] } keys %freq;\n\n    if (@nodes == 1) {\n        return {$nodes[0][0] => '0'};\n    }\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub length_encoder {\n    my ($str) = @_;\n\n    my %table;\n    my @chars = split(//, $str);\n\n    my $lim = $#chars;\n\n    my %t;\n    for (my $i = 0 ; $i < $lim ; $i++) {\n        for (my $j = $i + 1 ; $j <= $lim ; $j++) {\n            last if $j + ($j - $i) + 1 > $lim;\n            my $key = join('', @chars[$i .. $j]);\n            if (join('', @chars[$j + 1 .. $j + ($j - $i) + 1]) eq $key) {\n                if (not exists $t{$key}) {\n                    if (exists $t{substr($key, 0, -1)}) {\n                        last;\n                    }\n                    $t{$key} = length($key);\n                }\n                else {\n                    $t{$key}++;\n                }\n            }\n        }\n    }\n\n    my ($dict) = keys(%t) ? mktree(%t) : {};\n    my @sorted_tokens =\n      sort { length($dict->{$a}) <=> length($dict->{$b}) or $t{$b} <=> $t{$a} or $a cmp $b } keys %t;\n\n    say \"Weights: \", pp(\\%t);\n    say \"Sorted: @sorted_tokens\";\n    say \"Bits: \", pp($dict);\n\n    my $regex = do {\n        my @tries = map { \"(?<token>\\Q$_\\E)(?<rest>(?:\\Q$_\\E)*+)\" } @sorted_tokens;\n        local $\" = '|';\n        @sorted_tokens ? qr/^(?:@tries|(?<token>.))/s : qr/^(?<token>.)/s;\n    };\n\n    my $enc = '';\n\n    while ($str =~ s/$regex//) {\n        my $m = $+{token};\n        my $r = $+{rest};\n        if (defined $r) {\n            $enc .= (\"[$dict->{$m}x\" . (1 + length($r) / length($m)) . \"]\");\n        }\n        else {\n            $enc .= $m;\n        }\n    }\n\n    return $enc;\n}\n\nforeach my $str (\n                 qw(\n                 ABABABAB\n                 ABABABABAAAAAAAAAAAAAFFFFFFFFFFFFFFFFFFFDDDDDDDDDDDDDDDDDDDDJKLABABVADSABABAB\n                 DABDDB DABDDBBDDBA ABBDDD ABRACADABRA TOBEORNOTTOBEORTOBEORNOT\n                 )\n  ) {\n\n    say \"Encoding: $str\";\n    say \"Encoded: \", length_encoder($str);\n    say \"-\" x 80;\n}\n"
  },
  {
    "path": "Encoding/lz77_encoding.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 02 May 2024\n# https://github.com/trizen\n\n# Simple implementation of LZ77 encoding.\n\nuse 5.036;\n\nsub lz77_encode ($str) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    my (@literals, @distances, @lengths);\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n <= 255\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        --$n;\n        push @distances, $la - $p;\n        push @lengths,   $n;\n        push @literals,  $chars[$la + $n];\n        $la += $n + 1;\n        $prefix .= $token;\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\nsub lz77_decode ($literals, $distances, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#$literals) {\n        $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]) . $literals->[$i];\n        $offset += $lengths->[$i] + 1;\n    }\n\n    return $chunk;\n}\n\nmy $string = \"TOBEORNOTTOBEORTOBEORNOT\";\n\nmy ($literals, $distances, $lengths) = lz77_encode($string);\nmy $decoded = lz77_decode($literals, $distances, $lengths);\n\n$string eq $decoded or die \"error: <<$string>> != <<$decoded>>\";\n\nforeach my $i (0 .. $#$literals) {\n    say \"$literals->[$i] -- [$distances->[$i], $lengths->[$i]]\";\n}\n\nforeach my $file (__FILE__, $^X) {    # several tests\n\n    my $string = do {\n        open my $fh, '<:raw', $file or die \"error for <<$file>>: $!\";\n        local $/;\n        <$fh>;\n    };\n\n    my ($literals, $distances, $lengths) = lz77_encode($string);\n    my $decoded = lz77_decode($literals, $distances, $lengths);\n\n    $string eq $decoded or die \"error: <<$string>> != <<$decoded>>\";\n}\n\n__END__\nT -- [0, 0]\nO -- [0, 0]\nB -- [0, 0]\nE -- [0, 0]\nR -- [3, 1]\nN -- [0, 0]\nT -- [3, 1]\nT -- [9, 6]\nT -- [15, 7]\n"
  },
  {
    "path": "Encoding/lz77_encoding_symbolic.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 03 May 2024\n# https://github.com/trizen\n\n# Symbolic implementation of LZ77 encoding, using an hash table.\n\nuse 5.036;\n\nsub lz77_encode_symbolic ($symbols) {\n\n    if (ref($symbols) eq '') {\n        return __SUB__->(string2symbols($symbols));\n    }\n\n    my $la  = 0;\n    my $end = $#$symbols;\n\n    my $min_len       = 4;                # minimum match length\n    my $max_len       = 255;              # maximum match length\n    my $max_dist      = (1 << 16) - 1;    # maximum match distance\n    my $max_chain_len = 16;               # how many recent positions to keep track of\n\n    my (@literals, @distances, @lengths, %table);\n\n    while ($la <= $end) {\n\n        my $best_n = 1;\n        my $best_p = $la;\n\n        my @lookahead_symbols;\n        if ($la + $min_len - 1 <= $end) {\n            push @lookahead_symbols, @{$symbols}[$la .. $la + $min_len - 1];\n        }\n        else {\n            for (my $j = 0 ; ($j < $min_len and $la + $j <= $end) ; ++$j) {\n                push @lookahead_symbols, $symbols->[$la + $j];\n            }\n        }\n\n        my $lookahead = join(' ', @lookahead_symbols);\n\n        if (exists($table{$lookahead})) {\n\n            foreach my $p (@{$table{$lookahead}}) {\n\n                if ($la - $p > $max_dist) {\n                    last;\n                }\n\n                my $n = $min_len;\n\n                while ($n <= $max_len and $la + $n <= $end and $symbols->[$la + $n - 1] == $symbols->[$p + $n - 1]) {\n                    ++$n;\n                }\n\n                if ($n > $best_n) {\n                    $best_p = $p;\n                    $best_n = $n;\n                }\n            }\n\n            my @matched = @{$symbols}[$la .. $la + $best_n - 1];\n\n            foreach my $i (0 .. scalar(@matched) - $min_len) {\n\n                my $key = join(' ', @matched[$i .. $i + $min_len - 1]);\n                unshift @{$table{$key}}, $la + $i;\n\n                if (scalar(@{$table{$key}}) > $max_chain_len) {\n                    pop @{$table{$key}};\n                }\n            }\n        }\n\n        if ($best_n == 1) {\n            $table{$lookahead} = [$la];\n        }\n\n        --$best_n;\n\n        if ($best_n >= $min_len) {\n\n            push @lengths,   $best_n;\n            push @distances, $la - $best_p;\n            push @literals,  $symbols->[$la + $best_n];\n\n            $la += $best_n + 1;\n        }\n        else {\n            my @bytes = @{$symbols}[$best_p .. $best_p + $best_n];\n\n            push @lengths,   (0) x scalar(@bytes);\n            push @distances, (0) x scalar(@bytes);\n            push @literals, @bytes;\n\n            $la += $best_n + 1;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\nsub lz77_decode_symbolic ($literals, $distances, $lengths) {\n\n    my @data;\n    my $data_len = 0;\n\n    foreach my $i (0 .. $#$lengths) {\n\n        if ($lengths->[$i] != 0) {\n            my $length = $lengths->[$i];\n            my $dist   = $distances->[$i];\n\n            foreach my $j (1 .. $length) {\n                push @data, $data[$data_len + $j - $dist - 1];\n            }\n\n            $data_len += $length;\n        }\n\n        push @data, $literals->[$i];\n        $data_len += 1;\n    }\n\n    return \\@data;\n}\n\nmy $string = \"abbaabbaabaabaaaa\";\n\nmy ($literals, $distances, $lengths) = lz77_encode_symbolic([unpack('C*', $string)]);\nmy $decoded = lz77_decode_symbolic($literals, $distances, $lengths);\n\n$string eq pack('C*', @$decoded) or die \"error: <<$string>> != <<@$decoded>>\";\n\nforeach my $i (0 .. $#$literals) {\n    say \"$literals->[$i] -- [$distances->[$i], $lengths->[$i]]\";\n}\n\nforeach my $file (__FILE__, $^X) {    # several tests\n\n    my $string = do {\n        open my $fh, '<:raw', $file or die \"error for <<$file>>: $!\";\n        local $/;\n        <$fh>;\n    };\n\n    my ($literals, $distances, $lengths) = lz77_encode_symbolic([unpack('C*', $string)]);\n    my $decoded = lz77_decode_symbolic($literals, $distances, $lengths);\n\n    $string eq pack('C*', @$decoded) or die \"error: <<$string>> != <<@$decoded>>\";\n}\n"
  },
  {
    "path": "Encoding/lzss_encoding.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 03 May 2024\n# https://github.com/trizen\n\n# Simple implementation of LZSS encoding.\n\nuse 5.036;\n\nsub lzss_encode ($str) {\n\n    my $la = 0;\n\n    my $prefix = '';\n    my @chars  = split(//, $str);\n    my $end    = $#chars;\n\n    my $min_len = 3;\n    my $max_len = 255;\n\n    my (@literals, @distances, @lengths);\n\n    while ($la <= $end) {\n\n        my $n = 1;\n        my $p = length($prefix);\n        my $tmp;\n\n        my $token = $chars[$la];\n\n        while (    $n <= $max_len\n               and $la + $n <= $end\n               and ($tmp = rindex($prefix, $token, $p)) >= 0) {\n            $p = $tmp;\n            $token .= $chars[$la + $n];\n            ++$n;\n        }\n\n        if ($n > $min_len) {\n\n            push @lengths,   $n - 1;\n            push @distances, $la - $p;\n            push @literals,  undef;\n\n            $la += $n - 1;\n            $prefix .= substr($token, 0, -1);\n        }\n        else {\n            my @bytes = split(//, substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]);\n\n            push @lengths,   (0) x scalar(@bytes);\n            push @distances, (0) x scalar(@bytes);\n            push @literals, @bytes;\n\n            $la += $n;\n            $prefix .= $token;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\nsub lzss_decode ($literals, $distances, $lengths) {\n\n    my $chunk  = '';\n    my $offset = 0;\n\n    foreach my $i (0 .. $#$literals) {\n        if ($lengths->[$i] != 0) {\n            $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]);\n            $offset += $lengths->[$i];\n        }\n        else {\n            $chunk .= $literals->[$i];\n            $offset += 1;\n        }\n    }\n\n    return $chunk;\n}\n\nmy $string = \"TOBEORNOTTOBEORTOBEORNOT\";\n\nmy ($literals, $distances, $lengths) = lzss_encode($string);\nmy $decoded = lzss_decode($literals, $distances, $lengths);\n\n$string eq $decoded or die \"error: <<$string>> != <<$decoded>>\";\n\nforeach my $i (0 .. $#$literals) {\n    if ($lengths->[$i] == 0) {\n        say $literals->[$i];\n    }\n    else {\n        say \"[$distances->[$i], $lengths->[$i]]\";\n    }\n}\n\nforeach my $file (__FILE__, $^X) {    # several tests\n\n    my $string = do {\n        open my $fh, '<:raw', $file or die \"error for <<$file>>: $!\";\n        local $/;\n        <$fh>;\n    };\n\n    my ($literals, $distances, $lengths) = lzss_encode($string);\n    my $decoded = lzss_decode($literals, $distances, $lengths);\n\n    say \"Ratio: \", scalar(@$literals) / scalar(grep { defined($_) } @$literals);\n\n    $string eq $decoded or die \"error: <<$string>> != <<$decoded>>\";\n}\n\n__END__\nT\nO\nB\nE\nO\nR\nN\nO\nT\n[9, 6]\n[15, 8]\nT\nRatio: 1.44887348353553\nRatio: 1.50565184626978\n"
  },
  {
    "path": "Encoding/lzss_encoding_hash_table.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 02 May 2024\n# https://github.com/trizen\n\n# Implementation of LZSS encoding, using an hash table.\n\nuse 5.036;\n\nsub lzss_encode ($str) {\n\n    my $la = 0;\n\n    my @chars = split(//, $str);\n    my $end   = $#chars;\n\n    my $min_len       = 4;                # minimum match length\n    my $max_len       = 255;              # maximum match length\n    my $max_dist      = (1 << 16) - 1;    # maximum match distance\n    my $max_chain_len = 16;               # how many recent positions to keep track of\n\n    my (@literals, @distances, @lengths, %table);\n\n    while ($la <= $end) {\n\n        my $best_n = 1;\n        my $best_p = $la;\n\n        my $lookahead = substr($str, $la, $min_len);\n\n        if (exists($table{$lookahead})) {\n\n            foreach my $p (@{$table{$lookahead}}) {\n\n                if ($la - $p > $max_dist) {\n                    last;\n                }\n\n                my $n = $min_len;\n\n                while ($n <= $max_len and $la + $n <= $end and $chars[$la + $n - 1] eq $chars[$p + $n - 1]) {\n                    ++$n;\n                }\n\n                if ($n > $best_n) {\n                    $best_p = $p;\n                    $best_n = $n;\n                }\n            }\n\n            my $matched = substr($str, $la, $best_n);\n\n            foreach my $i (0 .. length($matched) - $min_len) {\n\n                my $key = substr($matched, $i, $min_len);\n                unshift @{$table{$key}}, $la + $i;\n\n                if (scalar(@{$table{$key}}) > $max_chain_len) {\n                    pop @{$table{$key}};\n                }\n            }\n        }\n\n        if ($best_n == 1) {\n            $table{$lookahead} = [$la];\n        }\n\n        if ($best_n > $min_len) {\n\n            push @lengths,   $best_n - 1;\n            push @distances, $la - $best_p;\n            push @literals,  undef;\n\n            $la += $best_n - 1;\n        }\n        else {\n\n            push @lengths,   (0) x $best_n;\n            push @distances, (0) x $best_n;\n            push @literals, @chars[$best_p .. $best_p + $best_n - 1];\n\n            $la += $best_n;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\nsub lzss_decode ($literals, $distances, $lengths) {\n\n    my @data;\n    my $data_len = 0;\n\n    foreach my $i (0 .. $#$lengths) {\n\n        if ($lengths->[$i] == 0) {\n            push @data, $literals->[$i];\n            $data_len += 1;\n            next;\n        }\n\n        my $length = $lengths->[$i];\n        my $dist   = $distances->[$i];\n\n        foreach my $j (1 .. $length) {\n            push @data, $data[$data_len + $j - $dist - 1];\n        }\n\n        $data_len += $length;\n    }\n\n    return join('', @data);\n}\n\nmy $string = \"abbaabbaabaabaaaa\";\n\nmy ($literals, $distances, $lengths) = lzss_encode($string);\nmy $decoded = lzss_decode($literals, $distances, $lengths);\n\n$string eq $decoded or die \"error: <<$string>> != <<$decoded>>\";\n\nforeach my $i (0 .. $#$literals) {\n    if ($lengths->[$i] == 0) {\n        say $literals->[$i];\n    }\n    else {\n        say \"[$distances->[$i], $lengths->[$i]]\";\n    }\n}\n\nforeach my $file (__FILE__, $^X) {    # several tests\n\n    my $string = do {\n        open my $fh, '<:raw', $file or die \"error for <<$file>>: $!\";\n        local $/;\n        <$fh>;\n    };\n\n    my ($literals, $distances, $lengths) = lzss_encode($string);\n    my $decoded = lzss_decode($literals, $distances, $lengths);\n\n    say \"Ratio: \", scalar(@$literals) / scalar(grep { defined($_) } @$literals);\n\n    $string eq $decoded or die \"error: <<$string>> != <<$decoded>>\";\n}\n\n__END__\na\nb\nb\na\n[4, 6]\n[3, 5]\na\na\nRatio: 1.35733333333333\nRatio: 1.44651830581479\n"
  },
  {
    "path": "Encoding/lzss_encoding_hash_table_fast.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 02 May 2024\n# https://github.com/trizen\n\n# Implementation of LZSS encoding, using an hash table.\n\n# A non-optimal, but very fast approach.\n\nuse 5.036;\n\nsub lzss_encode($str) {\n\n    my $la = 0;\n\n    my @symbols = unpack('C*', $str);\n    my $end     = $#symbols;\n\n    my $min_len  = 4;                # minimum match length\n    my $max_len  = 255;              # maximum match length\n    my $max_dist = (1 << 16) - 1;    # maximum match distance\n\n    my (@literals, @distances, @lengths, %table);\n\n    while ($la <= $end) {\n\n        my $best_n = 1;\n        my $best_p = $la;\n\n        my $lookahead = substr($str, $la, $min_len);\n\n        if (exists($table{$lookahead}) and $la - $table{$lookahead} <= $max_dist) {\n\n            my $p = $table{$lookahead};\n            my $n = $min_len;\n\n            while ($n <= $max_len and $la + $n <= $end and $symbols[$la + $n - 1] == $symbols[$p + $n - 1]) {\n                ++$n;\n            }\n\n            $best_p = $p;\n            $best_n = $n;\n        }\n\n        $table{$lookahead} = $la;\n\n        if ($best_n > $min_len) {\n\n            push @lengths,   $best_n - 1;\n            push @distances, $la - $best_p;\n            push @literals,  undef;\n\n            $la += $best_n - 1;\n        }\n        else {\n\n            push @lengths,   (0) x $best_n;\n            push @distances, (0) x $best_n;\n            push @literals, @symbols[$best_p .. $best_p + $best_n - 1];\n\n            $la += $best_n;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\nsub lzss_decode ($literals, $distances, $lengths) {\n\n    my @data;\n    my $data_len = 0;\n\n    foreach my $i (0 .. $#$lengths) {\n\n        if ($lengths->[$i] == 0) {\n            push @data, $literals->[$i];\n            $data_len += 1;\n            next;\n        }\n\n        my $length = $lengths->[$i];\n        my $dist   = $distances->[$i];\n\n        foreach my $j (1 .. $length) {\n            push @data, $data[$data_len + $j - $dist - 1];\n        }\n\n        $data_len += $length;\n    }\n\n    pack('C*', @data);\n}\n\nmy $string = \"abbaabbaabaabaaaa\";\n\nmy ($literals, $distances, $lengths) = lzss_encode($string);\nmy $decoded = lzss_decode($literals, $distances, $lengths);\n\n$string eq $decoded or die \"error: <<$string>> != <<$decoded>>\";\n\nforeach my $i (0 .. $#$literals) {\n    if ($lengths->[$i] == 0) {\n        say $literals->[$i];\n    }\n    else {\n        say \"[$distances->[$i], $lengths->[$i]]\";\n    }\n}\n\nforeach my $file (__FILE__, $^X) {    # several tests\n\n    my $string = do {\n        open my $fh, '<:raw', $file or die \"error for <<$file>>: $!\";\n        local $/;\n        <$fh>;\n    };\n\n    my ($literals, $distances, $lengths) = lzss_encode($string);\n    my $decoded = lzss_decode($literals, $distances, $lengths);\n\n    say \"Ratio: \", scalar(@$literals) / scalar(grep { defined($_) } @$literals);\n\n    $string eq $decoded or die \"error: <<$string>> != <<$decoded>>\";\n}\n\n__END__\n97\n98\n98\n97\n[4, 6]\n97\n97\n98\n97\n97\n97\n97\nRatio: 1.36301369863014\nRatio: 1.46043165467626\n"
  },
  {
    "path": "Encoding/lzss_encoding_symbolic.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 02 May 2024\n# https://github.com/trizen\n\n# Symbolic implementation of LZSS encoding, using an hash table.\n\nuse 5.036;\n\nsub lzss_encode_symbolic ($symbols) {\n\n    my $la  = 0;\n    my $end = $#$symbols;\n\n    my $min_len       = 4;                # minimum match length\n    my $max_len       = 255;              # maximum match length\n    my $max_dist      = (1 << 16) - 1;    # maximum match distance\n    my $max_chain_len = 16;               # how many recent positions to keep track of\n\n    my (@literals, @distances, @lengths, %table);\n\n    while ($la <= $end) {\n\n        my $best_n = 1;\n        my $best_p = $la;\n\n        my @lookahead_symbols;\n        if ($la + $min_len - 1 <= $end) {\n            push @lookahead_symbols, @{$symbols}[$la .. $la + $min_len - 1];\n        }\n        else {\n            for (my $j = 0 ; ($j < $min_len and $la + $j <= $end) ; ++$j) {\n                push @lookahead_symbols, $symbols->[$la + $j];\n            }\n        }\n\n        my $lookahead = join(' ', @lookahead_symbols);\n\n        if (exists($table{$lookahead})) {\n\n            foreach my $p (@{$table{$lookahead}}) {\n\n                if ($la - $p > $max_dist) {\n                    last;\n                }\n\n                my $n = $min_len;\n\n                while ($n <= $max_len and $la + $n <= $end and $symbols->[$la + $n - 1] == $symbols->[$p + $n - 1]) {\n                    ++$n;\n                }\n\n                if ($n > $best_n) {\n                    $best_p = $p;\n                    $best_n = $n;\n                }\n            }\n\n            my @matched = @{$symbols}[$la .. $la + $best_n - 1];\n\n            foreach my $i (0 .. scalar(@matched) - $min_len) {\n\n                my $key = join(' ', @matched[$i .. $i + $min_len - 1]);\n                unshift @{$table{$key}}, $la + $i;\n\n                if (scalar(@{$table{$key}}) > $max_chain_len) {\n                    pop @{$table{$key}};\n                }\n            }\n        }\n\n        if ($best_n == 1) {\n            $table{$lookahead} = [$la];\n        }\n\n        if ($best_n > $min_len) {\n\n            push @lengths,   $best_n - 1;\n            push @distances, $la - $best_p;\n            push @literals,  undef;\n\n            $la += $best_n - 1;\n        }\n        else {\n\n            push @lengths,   (0) x $best_n;\n            push @distances, (0) x $best_n;\n            push @literals, @$symbols[$best_p .. $best_p + $best_n - 1];\n\n            $la += $best_n;\n        }\n    }\n\n    return (\\@literals, \\@distances, \\@lengths);\n}\n\nsub lzss_decode_symbolic ($literals, $distances, $lengths) {\n\n    my @data;\n    my $data_len = 0;\n\n    foreach my $i (0 .. $#$lengths) {\n\n        if ($lengths->[$i] == 0) {\n            push @data, $literals->[$i];\n            $data_len += 1;\n            next;\n        }\n\n        my $length = $lengths->[$i];\n        my $dist   = $distances->[$i];\n\n        foreach my $j (1 .. $length) {\n            push @data, $data[$data_len + $j - $dist - 1];\n        }\n\n        $data_len += $length;\n    }\n\n    return \\@data;\n}\n\nmy $string = \"abbaabbaabaabaaaa\";\n\nmy ($literals, $distances, $lengths) = lzss_encode_symbolic([unpack('C*', $string)]);\nmy $decoded = lzss_decode_symbolic($literals, $distances, $lengths);\n\n$string eq pack('C*', @$decoded) or die \"error: <<$string>> != <<@$decoded>>\";\n\nforeach my $i (0 .. $#$literals) {\n    if ($lengths->[$i] == 0) {\n        say $literals->[$i];\n    }\n    else {\n        say \"[$distances->[$i], $lengths->[$i]]\";\n    }\n}\n\nforeach my $file (__FILE__, $^X) {    # several tests\n\n    my $string = do {\n        open my $fh, '<:raw', $file or die \"error for <<$file>>: $!\";\n        local $/;\n        <$fh>;\n    };\n\n    my ($literals, $distances, $lengths) = lzss_encode_symbolic([unpack('C*', $string)]);\n    my $decoded = lzss_decode_symbolic($literals, $distances, $lengths);\n\n    say \"Ratio: \", scalar(@$literals) / scalar(grep { defined($_) } @$literals);\n\n    $string eq pack('C*', @$decoded) or die \"error: <<$string>> != <<@$decoded>>\";\n}\n\n__END__\n97\n98\n98\n97\n[4, 6]\n[3, 5]\n97\n97\nRatio: 1.38851802403204\nRatio: 1.44651830581479\n"
  },
  {
    "path": "Encoding/lzt-fast.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 26 April 2015\n# Website: https://github.com/trizen\n\n# A very good and very fast compression algorithm. (concept only)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub lzt_compress {\n    my ($str) = @_;\n\n    my $k   = 0;     # must be zero\n    my $min = 4;     # the minimum length of a substring\n    my $max = 15;    # the maximum length of a substring\n\n    my $i        = 0;     # iterator (0 to length(str)-1)\n    my $remember = 0;     # remember mode\n    my $memo     = '';    # short-term memory\n\n    my @dups;             # array of duplicated substrings with positions\n    my @cache;            # cache of substrings\n    my %dict;             # dictionary of substrings\n\n    foreach my $c (split(//, $str)) {\n\n        if (not $remember and exists $dict{$c}) {\n            $remember = 1;    # activate the remember mode\n        }\n\n        $cache[$_] .= $c for ($k .. $i);    # create the substrings\n\n        # If remember mode is one, do some checks.\n        if ($remember) {\n\n            # Check to see if $memo + the current character exists in the dictionary\n            if (exists $dict{$memo . $c}) {\n                ## say \"found in cache [$i]: $memo$c\";\n            }\n\n            # If it doesn't exists, then the $memo is the largest\n            # duplicated substring in the dictionary at this point.\n            else {\n                $remember = 0;                  # turn-off remember mode\n                if (length($memo) >= $min) {    # check for the minimum length of the word\n                    push @dups, [$dict{$memo}, length($memo), $memo, $i - length($memo)];\n                }\n\n                # $memo has been stored. Now, clear the memory.\n                $memo = '';\n            }\n\n            # Remember one more character\n            $memo .= $c;\n        }\n\n        # Increment the iterator\n        $i++;\n\n        # Create the dictionary from the cache of substrings\n        foreach my $item (@cache) {\n            exists($dict{$item})\n              || ($dict{$item} = $i - length($item));\n        }\n\n        # Update the minimum length\n        ++$k if (($i - $k) >= $max);\n    }\n\n    return \\@dups;\n}\n\n#\n## Usage\n#\n\nmy $str = @ARGV ? do { local $/; <> } : \"TOBEORNOTTOBEORTOBEORNOT#\";\nsay '[', join(', ', @{$_}), ']' for @{lzt_compress($str)};\n"
  },
  {
    "path": "Encoding/lzw_encoding.pl",
    "content": "#!/usr/bin/perl\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse constant DICT_SIZE => 256;\nuse experimental qw(signatures);\n\nbinmode(STDOUT, ':utf8');\n\nsub create_dictionary() {\n    my %dictionary;\n\n    foreach my $i (0 .. DICT_SIZE - 1) {\n        $dictionary{chr $i} = chr $i;\n    }\n\n    return %dictionary;\n}\n\nsub compress ($uncompressed) {\n\n    my $dict_size  = DICT_SIZE;\n    my %dictionary = create_dictionary();\n\n    my $w = '';\n    my @compressed;\n\n    foreach my $c (split(//, $uncompressed)) {\n        my $wc = $w . $c;\n        if (exists $dictionary{$wc}) {\n            $w = $wc;\n        }\n        else {\n            push @compressed, $dictionary{$w};\n            $dictionary{$wc} = chr($dict_size++);\n            $w = $c;\n        }\n    }\n\n    if ($w ne '') {\n        push @compressed, $dictionary{$w};\n    }\n\n    return @compressed;\n}\n\nsub decompress (@compressed) {\n\n    my $dict_size  = DICT_SIZE;\n    my %dictionary = create_dictionary();\n\n    my $w      = shift(@compressed);\n    my $result = $w;\n\n    foreach my $k (@compressed) {\n\n        my $entry = do {\n            if (exists $dictionary{$k}) {\n                $dictionary{$k};\n            }\n            elsif ($k eq chr($dict_size)) {\n                $w . substr($w, 0, 1);\n            }\n            else {\n                die \"Invalid compression: $k\";\n            }\n        };\n\n        $result .= $entry;\n        $dictionary{chr($dict_size++)} = $w . substr($entry, 0, 1);\n        $w = $entry;\n    }\n\n    return $result;\n}\n\nmy $orig = 'TOBEORNOTTOBEORTOBEORNOT';\n\nmy @compressed = compress($orig);\nmy $enc        = join('', @compressed);\nmy $dec        = decompress(@compressed);\n\nsay \"Encoded: $enc\";\nsay \"Decoded: $dec\";\n\nsay '-' x 33;\n\nif ($dec ne $orig) {\n    die \"Decompression failed!\";\n}\n\nprintf(\"Original    size  : %s\\n\",     length($orig));\nprintf(\"Compressed  size  : %s\\n\",     length($enc));\nprintf(\"Compression ratio : %.2f%%\\n\", (length($orig) - length($enc)) / length($orig) * 100);\n"
  },
  {
    "path": "Encoding/math_expr_encoder.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 14 April 2012\n# https://github.com/trizen\n\n@ARGV = @ARGV ? (@ARGV) : ($0);\n\nforeach my $file (grep { -f } @ARGV) {\n    open my $fh, '<', $file or next;\n    my $s = '';\n    while (1) {\n        my $i = ord(getc($fh) // last);\n        while (1) {\n            my $f = int rand $i;\n            my $l = int rand $i * 2;\n            if (($f | $l) == $i)  { $s .= \"$f|$l,\"  => last }\n            if (($f * $l) == $i)  { $s .= \"$f*$l,\"  => last }\n            if (($l >> $f) == $i) { $s .= \"$l>>$f,\" => last }\n            if (($f << $l) == $i) { $s .= \"$f<<$l,\" => last }\n            if (($l << $f) == $i) { $s .= \"$l<<$f,\" => last }\n            if (($f**$l) == $i)   { $s .= \"$f**$l,\" => last }\n            if (($l**$f) == $i)   { $s .= \"$l**$f,\" => last }\n            if (($f + $l) == $i)  { $s .= \"$f+$l,\"  => last }\n            if (($l - $f) == $i)  { $s .= \"$l-$f,\"  => last }\n            if (($f ^ $l) == $i)  { $s .= \"$f^$l,\"  => last }\n        }\n    }\n    close $fh;\n\n    print <<\"EOT\";\nprint chr for $s;\nEOT\n}\n"
  },
  {
    "path": "Encoding/move-to-front_transform.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 13 June 2023\n# https://github.com/trizen\n\n# The Move to Front transform (MTF).\n\n# Reference:\n#   COMP526 Unit 7-6 2020-03-24 Compression - Move-to-front transform\n#   https://youtube.com/watch?v=Q2pinaj3i9Y\n\nuse 5.036;\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@{$alphabet}, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@{$alphabet}, $p, 1));\n    }\n\n    return \\@S;\n}\n\nmy $str = \"INEFICIENCIES\";\n\nmy $encoded = mtf_encode([unpack('C*', $str)], [ord('A') .. ord('Z')]);\nmy $decoded = mtf_decode($encoded, [ord('A') .. ord('Z')]);\n\nsay \"Encoded: \", \"@$encoded\";              #=> Encoded: 8 13 6 7 3 6 1 3 4 3 3 3 18\nsay \"Decoded: \", pack('C*', @$decoded);    #=> Decoded: INEFICIENCIES\n\n$str eq pack('C*', @$decoded) or die \"error\";\n\n{\n    open my $fh, '<:raw', __FILE__;\n    my $str     = do { local $/; <$fh> };\n    my $encoded = mtf_encode([unpack('C*', $str)]);\n    my $decoded = mtf_decode($encoded);\n    $str eq pack('C*', @$decoded) or die \"error\";\n}\n"
  },
  {
    "path": "Encoding/mtf-delta_encoding.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 13 June 2023\n# https://github.com/trizen\n\n# Implementation of the Move-to-Front transform, combined with Delta encoding.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 6 - Delta Compression and Prediction\n#   https://youtube.com/watch?v=-3H_eDbWNEU\n#\n#   COMP526 Unit 7-6 2020-03-24 Compression - Move-to-front transform\n#   https://youtube.com/watch?v=Q2pinaj3i9Y\n\nuse 5.036;\n\nsub mtf_encode ($bytes, $alphabet = [0 .. 255]) {\n\n    my @C;\n\n    my @table;\n    @table[@$alphabet] = (0 .. $#{$alphabet});\n\n    foreach my $c (@$bytes) {\n        push @C, (my $index = $table[$c]);\n        unshift(@$alphabet, splice(@{$alphabet}, $index, 1));\n        @table[@{$alphabet}[0 .. $index]] = (0 .. $index);\n    }\n\n    return \\@C;\n}\n\nsub mtf_decode ($encoded, $alphabet = [0 .. 255]) {\n\n    my @S;\n\n    foreach my $p (@$encoded) {\n        push @S, $alphabet->[$p];\n        unshift(@$alphabet, splice(@{$alphabet}, $p, 1));\n    }\n\n    return \\@S;\n}\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub delta_encode ($bytes) {    # all bytes in the range [0, 255]\n\n    my @deltas;\n    my $prev = 0;\n\n    my $integers = mtf_encode($bytes);\n    unshift(@$integers, scalar(@$integers));\n\n    while (@$integers) {\n        my $curr = shift(@$integers);\n        push @deltas, $curr - $prev;\n        $prev = $curr;\n    }\n\n    my $bitstring = '';\n\n    foreach my $d (@deltas) {\n        if ($d == 0) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', abs($d));\n            $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub delta_decode ($str) {\n\n    open my $fh, '<:raw', \\$str;\n\n    my @deltas;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer);\n\n        if ($bit eq '0') {\n            push @deltas, 0;\n        }\n        else {\n            my $bit = read_bit($fh, \\$buffer);\n            my $n   = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @deltas, ($bit eq '1' ? $d : -$d);\n        }\n\n        if ($k == 0) {\n            $len = pop(@deltas);\n        }\n    }\n\n    my @acc;\n    my $prev = $len;\n\n    foreach my $d (@deltas) {\n        $prev += $d;\n        push @acc, $prev;\n    }\n\n    mtf_decode(\\@acc);\n}\n\nmy @bytes = do {\n    open my $fh, '<:raw', $^X;\n    local $/;\n    unpack('C*', <$fh>);\n};\n\nmy $str = delta_encode([@bytes]);\n\nsay \"Encoded length: \", length($str);\nsay \"Rawdata length: \", length(pack('C*', @bytes));\n\nmy $decoded = delta_decode($str);\njoin(' ', @bytes) eq join(' ', @$decoded) or die \"Decoding error\";\n\n__END__\nEncoded length: 5270\nRawdata length: 14168\n"
  },
  {
    "path": "Encoding/png_transform.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 21 December 2023\n# https://github.com/trizen\n\n# Apply the reversible PNG transform on arbitrary data.\n\n# The transformation can be made irreversible by lossy\n# compressing the PNG file with a tool like \"pngquant\".\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse GD           qw();\nuse Getopt::Long qw(GetOptions);\nuse experimental qw(signatures);\n\nGD::Image->trueColor(1);\n\nbinmode(STDIN,  ':raw');\nbinmode(STDOUT, ':raw');\n\nsub encode_data ($data) {\n\n    my @bytes = unpack(\"C*\", $data);\n\n    my $c      = 1 + int(scalar(@bytes) / 3);\n    my $width  = int(sqrt($c));\n    my $height = int($c / $width) + 1;\n\n    say STDERR \":: File size: \", scalar(@bytes);\n    say STDERR \":: Image size: $width x $height\";\n\n    my $image = GD::Image->new($width, $height)\n      or die \"Can't create image\";\n\n    my $size = scalar(@bytes);\n\n  OUTER: foreach my $y (0 .. $height - 1) {\n        foreach my $x (0 .. $width - 1) {\n            if ($size > 0) {\n                my $index = $image->colorResolve(shift(@bytes) // 0, shift(@bytes) // 0, shift(@bytes) // 0);\n                $image->setPixel($x, $y, $index);\n                $size -= 3;\n            }\n            else {\n                last OUTER;\n            }\n        }\n    }\n\n    return $image;\n}\n\nsub decode_data ($img_data, $length) {\n\n    my $image = GD::Image->new($img_data)\n      or die \"Can't read image: $!\";\n\n    my ($width, $height) = $image->getBounds();\n\n    my $data = '';\n    my $size = 0;\n\n  OUTER: foreach my $y (0 .. $height - 1) {\n        foreach my $x (0 .. $width - 1) {\n            my $index = $image->getPixel($x, $y);\n            if ($size < $length) {\n                my ($red, $green, $blue) = $image->rgb($index);\n                $data .= pack('C3', $red, $green, $blue);\n                $size += 3;\n            }\n            else {\n                last OUTER;\n            }\n        }\n    }\n\n    while (length($data) > $length) {\n        chop $data;\n    }\n\n    return $data;\n}\n\nmy $compression = 9;\nmy $decode_size = undef;\n\nsub help ($exit_code = 0) {\n    print <<\"EOT\";\nusage: $0 [options] [input] [output]\n\noptions:\n\n    -d --decode=size : how many bytes to decode\n\nexample:\n\n    # Encode\n    perl $0 input.txt encoded.png\n\n    # Decode\n    perl $0 -d=size encoded.png decoded.txt\n\nEOT\n\n    exit($exit_code);\n}\n\nGetOptions('d|decode=s' => \\$decode_size,\n           \"h|help\"     => sub { help(0) },)\n  or die(\"Error in command line arguments\\n\");\n\nmy $data_file   = shift(@ARGV) // help(2);\nmy $output_file = shift(@ARGV);\n\nmy $data = do {\n    open my $fh, '<:raw', $data_file\n      or die \"Can't open file <<$data_file>> for reading: $!\";\n    local $/;\n    <$fh>;\n};\n\nif (defined($decode_size)) {\n\n    my $decoded = decode_data($data, $decode_size);\n\n    if (length($decoded) != $decode_size) {\n        warn sprintf(\"Incorrect size: len(T) = %d != len(D) = %d\\n\", length($decoded), length($data));\n    }\n\n    if (defined($output_file)) {\n        open my $fh, '>:raw', $output_file\n          or die \"Can't open file <<$output_file>> for writing: $!\";\n        print $fh $decoded;\n        close $fh;\n    }\n    else {\n        print $decoded;\n    }\n}\nelse {\n\n    my $img = encode_data($data);\n    my $png = $img->png($compression);\n\n    if (defined($output_file)) {\n        open my $fh, '>:raw', $output_file\n          or die \"Can't open file <<$output_file>> for writing: $!\";\n        print $fh $png;\n        close $fh;\n    }\n    else {\n        print $png;\n    }\n}\n"
  },
  {
    "path": "Encoding/ppm_encoding.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 10 August 2023\n# https://github.com/trizen\n\n# Implementation of a PPM (prediction by partial-matching) encoder, using Huffman Coding.\n\n# See also:\n#   https://rosettacode.org/wiki/huffman_coding\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 16 - Adaptive Methods\n#   https://youtube.com/watch?v=YKv-w8bXi9c\n\nuse 5.036;\nuse List::Util qw(max uniq);\n\nuse constant {\n              ESCAPE_SYMBOL => 256,    # escape symbol\n              CONTEXTS_NUM  => 4,      # maximum number of contexts\n              VERBOSE       => 0,      # verbose/debug mode\n             };\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub freq ($arr) {\n    my %freq;\n    ++$freq{$_} for @$arr;\n    return \\%freq;\n}\n\nsub encode ($symbols, $alphabet) {\n\n    my @enc;\n    my @prev;\n    my $s = join(' ', @prev);\n\n    my @ctx = ({$s => {freq => freq($alphabet)}},);\n\n    foreach my $i (1 .. CONTEXTS_NUM) {\n        push @ctx, {$s => {freq => freq([ESCAPE_SYMBOL])}};\n    }\n\n    foreach my $c (@ctx) {\n        $c->{$s}{tree} = (mktree_from_freq($c->{$s}{freq}))[0];\n    }\n\n    foreach my $symbol (@$symbols) {\n\n        foreach my $k (reverse(0 .. $#ctx)) {\n            $s = join(' ', @prev[max($#prev - $k + 2, 0) .. $#prev]);\n\n            if (!exists($ctx[$k]{$s})) {\n                $ctx[$k]{$s}{freq} = freq([ESCAPE_SYMBOL]);\n            }\n\n            if (exists($ctx[$k]{$s}{freq}{$symbol})) {\n\n                if ($k != 0) {\n                    $ctx[$k]{$s}{tree} = (mktree_from_freq($ctx[$k]{$s}{freq}))[0];\n                    ++$ctx[$k]{$s}{freq}{$symbol};\n                }\n\n                say STDERR \"Encoding $symbol with context=$k using $ctx[$k]{$s}{tree}{$symbol} and prefix ($s)\" if VERBOSE;\n                push @enc, $ctx[$k]{$s}{tree}{$symbol};\n\n                push @prev, $symbol;\n                shift(@prev) if (scalar(@prev) >= CONTEXTS_NUM);\n                last;\n            }\n\n            $ctx[$k]{$s}{tree} = (mktree_from_freq($ctx[$k]{$s}{freq}))[0];\n            push @enc, $ctx[$k]{$s}{tree}{(ESCAPE_SYMBOL)};\n            say STDERR \"Escaping from context = $k with $ctx[$k]{$s}{tree}{(ESCAPE_SYMBOL)}\" if VERBOSE;\n            $ctx[$k]{$s}{freq}{$symbol} = 1;\n        }\n    }\n\n    return join('', @enc);\n}\n\nsub decode ($enc, $alphabet) {\n\n    my @out;\n    my @prev;\n    my $prefix = '';\n    my $s      = join(' ', @prev);\n\n    my @ctx = ({$s => {freq => freq($alphabet)}},);\n\n    foreach my $i (1 .. CONTEXTS_NUM) {\n        push @ctx, {$s => {freq => freq([ESCAPE_SYMBOL])}},;\n    }\n\n    foreach my $c (@ctx) {\n        $c->{$s}{tree} = (mktree_from_freq($c->{$s}{freq}))[1];\n    }\n\n    my $context = CONTEXTS_NUM;\n    my @key     = @prev;\n\n    foreach my $bit (split(//, $enc)) {\n\n        $prefix .= $bit;\n\n        if (!exists($ctx[$context]{$s})) {\n            $ctx[$context]{$s}{freq} = freq([ESCAPE_SYMBOL]);\n            $ctx[$context]{$s}{tree} = (mktree_from_freq($ctx[$context]{$s}{freq}))[1];\n        }\n\n        if (exists($ctx[$context]{$s}{tree}{$prefix})) {\n            my $symbol = $ctx[$context]{$s}{tree}{$prefix};\n            if ($symbol == ESCAPE_SYMBOL) {\n                --$context;\n                shift(@key) if (scalar(@key) >= $context);\n                $s = join(' ', @key);\n            }\n            else {\n                push @out, $symbol;\n                foreach my $k (max($context, 1) .. CONTEXTS_NUM) {\n                    my $s = join(' ', @prev[max($#prev - $k + 2, 0) .. $#prev]);\n                    $ctx[$k]{$s}{freq} //= freq([ESCAPE_SYMBOL]);\n                    ++$ctx[$k]{$s}{freq}{$symbol};\n                    $ctx[$k]{$s}{tree} = (mktree_from_freq($ctx[$k]{$s}{freq}))[1];\n                }\n                $context = CONTEXTS_NUM;\n                push @prev, $symbol;\n                shift(@prev) if (scalar(@prev) >= CONTEXTS_NUM);\n                @key = @prev[max($#prev - $context + 2, 0) .. $#prev];\n                $s   = join(' ', @key);\n            }\n            $prefix = '';\n        }\n    }\n\n    return \\@out;\n}\n\nmy $text = \"A SAD DAD; A SAD SALSA\";\n##my $text = \"this is an example for huffman encoding\";\n\nmy @bytes = unpack('C*', $text);\n\nmy $enc = encode(\\@bytes, [uniq(@bytes)]);\nmy $dec = decode($enc, [uniq(@bytes)]);\n\nsay $enc;\nsay pack('C*', @$dec);\n\nprintf(\"Saved: %.3f%%\\n\", ((@$dec - length($enc) / 8) / @$dec * 100));\n\npack('C*', @$dec) eq $text or die \"Decoding failed!\";\n"
  },
  {
    "path": "Encoding/ppm_encoding_dynamic.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 10 August 2023\n# https://github.com/trizen\n\n# Implementation of a PPM (prediction by partial-matching) encoder, using Huffman Coding.\n\n# This variant dynamically increments the context-length, based on the input data, in order to reduce the number of escape symbols being generated.\n\n# See also:\n#   https://rosettacode.org/wiki/huffman_coding\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 16 - Adaptive Methods\n#   https://youtube.com/watch?v=YKv-w8bXi9c\n\nuse 5.036;\nuse List::Util qw(max uniq);\n\nuse constant {\n              ESCAPE_SYMBOL   => 256,    # escape symbol\n              CONTEXTS_NUM    => 3,      # maximum number of contexts\n              INITIAL_CONTEXT => 1,      # start in this context\n              VERBOSE         => 0,      # verbose/debug mode\n             };\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree_from_freq ($freq) {\n\n    my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x)) {\n            if (defined($y)) {\n                push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n            }\n            else {\n                push @nodes, [[$x], $x->[1]];\n            }\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub freq ($arr) {\n    my %freq;\n    ++$freq{$_} for @$arr;\n    return \\%freq;\n}\n\nsub encode ($symbols, $alphabet) {\n\n    my @enc;\n    my @prev;\n    my $s = join(' ', @prev);\n\n    my @ctx = ({$s => {freq => freq($alphabet)}},);\n\n    foreach my $i (1 .. CONTEXTS_NUM) {\n        push @ctx, {$s => {freq => freq([ESCAPE_SYMBOL])}};\n    }\n\n    foreach my $c (@ctx) {\n        $c->{$s}{tree} = (mktree_from_freq($c->{$s}{freq}))[0];\n    }\n\n    my $prev_ctx = INITIAL_CONTEXT;\n\n    foreach my $symbol (@$symbols) {\n\n        foreach my $k (reverse(0 .. $prev_ctx)) {\n            $s = join(' ', @prev[max($#prev - $k + 2, 0) .. $#prev]);\n\n            if (!exists($ctx[$k]{$s})) {\n                $ctx[$k]{$s}{freq} = freq([ESCAPE_SYMBOL]);\n            }\n\n            if (exists($ctx[$k]{$s}{freq}{$symbol})) {\n\n                if ($k != 0) {\n                    $ctx[$k]{$s}{tree} = (mktree_from_freq($ctx[$k]{$s}{freq}))[0];\n                    ++$ctx[$k]{$s}{freq}{$symbol};\n                }\n\n                say STDERR \"Encoding $symbol with context=$k using $ctx[$k]{$s}{tree}{$symbol} and prefix ($s)\" if VERBOSE;\n                push @enc, $ctx[$k]{$s}{tree}{$symbol};\n                ++$prev_ctx if ($prev_ctx < $#ctx);\n\n                push @prev, $symbol;\n                shift(@prev) if (scalar(@prev) >= CONTEXTS_NUM);\n                last;\n            }\n\n            --$prev_ctx;\n            $ctx[$k]{$s}{tree} = (mktree_from_freq($ctx[$k]{$s}{freq}))[0];\n            push @enc, $ctx[$k]{$s}{tree}{(ESCAPE_SYMBOL)};\n            say STDERR \"Escaping from context = $k with $ctx[$k]{$s}{tree}{(ESCAPE_SYMBOL)}\" if VERBOSE;\n            $ctx[$k]{$s}{freq}{$symbol} = 1;\n        }\n    }\n\n    return join('', @enc);\n}\n\nsub decode ($enc, $alphabet) {\n\n    my @out;\n    my @prev;\n    my $prefix = '';\n    my $s      = join(' ', @prev);\n\n    my @ctx = ({$s => {freq => freq($alphabet)}},);\n\n    foreach my $i (1 .. CONTEXTS_NUM) {\n        push @ctx, {$s => {freq => freq([ESCAPE_SYMBOL])}},;\n    }\n\n    foreach my $c (@ctx) {\n        $c->{$s}{tree} = (mktree_from_freq($c->{$s}{freq}))[1];\n    }\n\n    my $prev_ctx = my $context = INITIAL_CONTEXT;\n    my @key      = @prev;\n\n    foreach my $bit (split(//, $enc)) {\n\n        $prefix .= $bit;\n\n        if (!exists($ctx[$context]{$s})) {\n            $ctx[$context]{$s}{freq} = freq([ESCAPE_SYMBOL]);\n            $ctx[$context]{$s}{tree} = (mktree_from_freq($ctx[$context]{$s}{freq}))[1];\n        }\n\n        if (exists($ctx[$context]{$s}{tree}{$prefix})) {\n            my $symbol = $ctx[$context]{$s}{tree}{$prefix};\n            if ($symbol == ESCAPE_SYMBOL) {\n                --$context;\n                shift(@key) if (scalar(@key) >= $context);\n                $s = join(' ', @key);\n            }\n            else {\n                push @out, $symbol;\n                foreach my $k (max($context, 1) .. $prev_ctx) {\n                    my $s = join(' ', @prev[max($#prev - $k + 2, 0) .. $#prev]);\n                    $ctx[$k]{$s}{freq} //= freq([ESCAPE_SYMBOL]);\n                    ++$ctx[$k]{$s}{freq}{$symbol};\n                    $ctx[$k]{$s}{tree} = (mktree_from_freq($ctx[$k]{$s}{freq}))[1];\n                }\n                ++$context if ($context < $#ctx);\n                $prev_ctx = $context;\n                push @prev, $symbol;\n                shift(@prev) if (scalar(@prev) >= CONTEXTS_NUM);\n                @key = @prev[max($#prev - $context + 2, 0) .. $#prev];\n                $s   = join(' ', @key);\n            }\n            $prefix = '';\n        }\n    }\n\n    return \\@out;\n}\n\nmy $text = \"A SAD DAD; A SAD SALSA\";\n##my $text = \"this is an example for huffman encoding\";\n\nmy @bytes = unpack('C*', $text);\n\nmy $enc = encode(\\@bytes, [uniq(@bytes)]);\nmy $dec = decode($enc, [uniq(@bytes)]);\n\nsay $enc;\nsay pack('C*', @$dec);\n\nprintf(\"Saved: %.3f%%\\n\", ((@$dec - length($enc) / 8) / @$dec * 100));\n\npack('C*', @$dec) eq $text or die \"Decoding failed!\";\n"
  },
  {
    "path": "Encoding/rANS_encoding.pl",
    "content": "#!/usr/bin/perl\n\n# Basic implementation of rANS encoding.\n\n# Reference:\n#   ‎Stanford EE274: Data Compression I 2023 I Lecture 7 - ANS\n#   https://youtube.com/watch?v=5Hp4bnvSjng\n\nuse 5.036;\n\npackage rANS {\n\n    sub new {\n        my ($class, $input) = @_;\n\n        my %freq;\n        my %cumul;\n\n        ++$freq{$_} for @$input;\n\n        my @alphabet = sort { $a <=> $b } keys %freq;\n\n        my $t = 0;\n        foreach my $s (@alphabet) {\n            $cumul{$s} = $t;\n            $t += $freq{$s};\n        }\n\n        my $M = $t;\n\n        bless {\n               input    => $input,\n               M        => $M,\n               freq     => \\%freq,\n               cumul    => \\%cumul,\n               alphabet => \\@alphabet,\n              }, $class;\n    }\n\n    sub divint ($x, $y) {\n        use integer;\n        $x / $y;\n    }\n\n    sub divrem ($x, $y) {\n        use integer;\n        ($x / $y, $x % $y);\n    }\n\n    sub rans_base_enc($self, $x_prev, $s) {\n        my $block_id = divint($x_prev, $self->{freq}{$s});\n        my $slot     = $self->{cumul}{$s} + ($x_prev % $self->{freq}{$s});\n        my $x        = ($block_id * $self->{M} + $slot);\n        return $x;\n    }\n\n    sub encode($self) {\n        my $x = 0;\n        foreach my $s (@{$self->{input}}) {\n            $x = $self->rans_base_enc($x, $s);\n        }\n        return $x;\n    }\n\n    sub rans_base_dec($self, $x) {\n\n        my ($block_id, $slot) = divrem($x, $self->{M});\n        my $alphabet = $self->{alphabet};\n        my $cumul    = $self->{cumul};\n\n        my ($left, $right, $mid, $cmp) = (0, $#{$alphabet});\n\n        while (1) {\n\n            $mid = ($left + $right) >> 1;\n            $cmp = ($cumul->{$alphabet->[$mid]} <=> $slot) || last;\n\n            if ($cmp < 0) {\n                $left = $mid + 1;\n                $left > $right and last;\n            }\n            else {\n                $right = $mid - 1;\n\n                if ($left > $right) {\n                    $mid -= 1;\n                    last;\n                }\n            }\n        }\n\n        my $s      = $alphabet->[$mid];\n        my $x_prev = ($block_id * $self->{freq}{$s} + $slot - $cumul->{$s});\n        return ($s, $x_prev);\n    }\n\n    sub decode($self, $x, $n) {\n        my @dec;\n        my $s = undef;\n        for (1 .. $n) {\n            ($s, $x) = $self->rans_base_dec($x);\n            push @dec, $s;\n        }\n        return [reverse @dec];\n    }\n}\n\nmy @seq = (1, 2, 1, 7, 8, 2, 2, 1, 3, 3, 1, 1, 1, 2);\nmy $obj = rANS->new(\\@seq);\n\nmy $enc = $obj->encode;\nmy $dec = $obj->decode($enc, scalar(@seq));\n\nsay $enc;\nsay \"@$dec\";\n\njoin(' ', @seq) eq join(' ', @$dec) or die \"error\";\n"
  },
  {
    "path": "Encoding/rANS_encoding_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Basic implementation of rANS encoding, using big integers.\n\n# Reference:\n#   ‎Stanford EE274: Data Compression I 2023 I Lecture 7 - ANS\n#   https://youtube.com/watch?v=5Hp4bnvSjng\n\nuse 5.036;\nuse Math::GMPz;\n\npackage rANS {\n\n    sub new {\n        my ($class, $input) = @_;\n\n        my %freq;\n        my %cumul;\n\n        ++$freq{$_} for @$input;\n\n        my @alphabet = sort { $a <=> $b } keys %freq;\n\n        my $t = 0;\n        foreach my $s (@alphabet) {\n            $cumul{$s} = $t;\n            $t += $freq{$s};\n        }\n\n        my $M = $t;\n\n        bless {\n               input    => $input,\n               M        => $M,\n               freq     => \\%freq,\n               cumul    => \\%cumul,\n               alphabet => \\@alphabet,\n              }, $class;\n    }\n\n    sub rans_base_enc($self, $x_prev, $s, $block_id, $x) {\n\n        Math::GMPz::Rmpz_div_ui($block_id, $x_prev, $self->{freq}{$s});\n\n        my $r    = Math::GMPz::Rmpz_mod_ui($x, $x_prev, $self->{freq}{$s});\n        my $slot = $self->{cumul}{$s} + $r;\n\n        Math::GMPz::Rmpz_mul_ui($x, $block_id, $self->{M});\n        Math::GMPz::Rmpz_add_ui($x, $x, $slot);\n\n        return $x;\n    }\n\n    sub encode($self) {\n\n        my $x        = Math::GMPz::Rmpz_init_set_ui(0);\n        my $block_id = Math::GMPz::Rmpz_init();\n        my $next_x   = Math::GMPz::Rmpz_init();\n\n        foreach my $s (@{$self->{input}}) {\n            $x = $self->rans_base_enc($x, $s, $block_id, $next_x);\n        }\n\n        return $x;\n    }\n\n    sub rans_base_dec($self, $x, $block_id, $slot, $x_prev) {\n\n        Math::GMPz::Rmpz_tdiv_qr_ui($block_id, $slot, $x, $self->{M});\n\n        my $alphabet = $self->{alphabet};\n        my $cumul    = $self->{cumul};\n\n        my ($left, $right, $mid, $cmp) = (0, $#{$alphabet});\n\n        while (1) {\n\n            $mid = ($left + $right) >> 1;\n            $cmp = ($cumul->{$alphabet->[$mid]} <=> $slot) || last;\n\n            if ($cmp < 0) {\n                $left = $mid + 1;\n                $left > $right and last;\n            }\n            else {\n                $right = $mid - 1;\n\n                if ($left > $right) {\n                    $mid -= 1;\n                    last;\n                }\n            }\n        }\n\n        my $s = $alphabet->[$mid];\n\n        Math::GMPz::Rmpz_mul_ui($x_prev, $block_id, $self->{freq}{$s});\n        Math::GMPz::Rmpz_add($x_prev, $x_prev, $slot);\n        Math::GMPz::Rmpz_sub_ui($x_prev, $x_prev, $cumul->{$s});\n\n        return ($s, $x_prev);\n    }\n\n    sub decode($self, $x, $n) {\n        my @dec;\n        my $s = undef;\n\n        my $block_id = Math::GMPz::Rmpz_init();\n        my $slot     = Math::GMPz::Rmpz_init();\n        my $x_prev   = Math::GMPz::Rmpz_init();\n\n        for (1 .. $n) {\n            ($s, $x) = $self->rans_base_dec($x, $block_id, $slot, $x_prev);\n            push @dec, $s;\n        }\n\n        return [reverse @dec];\n    }\n}\n\nmy @seq = do {\n    open my $fh, '<:raw', __FILE__;\n    local $/;\n    unpack('C*', <$fh>);\n};\n\nmy $obj = rANS->new(\\@seq);\n\nmy $enc = $obj->encode;\nmy $dec = $obj->decode($enc, scalar(@seq));\n\nsay $enc;\n\njoin(' ', @seq) eq join(' ', @$dec) or die \"error\";\n"
  },
  {
    "path": "Encoding/run_length_with_elias_coding.pl",
    "content": "#!/usr/bin/perl\n\n# Implementation of Run-length + Elias coding, for encoding arbitrary non-negative integers.\n\n# References:\n#   Data Compression (Summer 2023) - Lecture 5 - Basic Techniques\n#   https://youtube.com/watch?v=TdFWb8mL5Gk\n#\n#   Data Compression (Summer 2023) - Lecture 6 - Delta Compression and Prediction\n#   https://youtube.com/watch?v=-3H_eDbWNEU\n\nuse 5.036;\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub run_length ($arr) {\n\n    @$arr || return [];\n\n    my @result     = [$arr->[0], 1];\n    my $prev_value = $arr->[0];\n\n    foreach my $i (1 .. $#{$arr}) {\n\n        my $curr_value = $arr->[$i];\n\n        if ($curr_value eq $prev_value) {\n            ++$result[-1][1];\n        }\n        else {\n            push(@result, [$curr_value, 1]);\n        }\n\n        $prev_value = $curr_value;\n    }\n\n    return \\@result;\n}\n\nsub RLEE_encoding ($integers, $double = 0) {\n\n    my @symbols = (scalar(@$integers), @$integers);\n\n    my $bitstring = '';\n    my $rle       = run_length(\\@symbols);\n\n    foreach my $cv (@$rle) {\n        my ($c, $v) = @$cv;\n\n        if ($c == 0) {\n            $bitstring .= '0';\n        }\n        elsif ($double) {\n            my $t = sprintf('%b', abs($c) + 1);\n            my $l = sprintf('%b', length($t));\n            $bitstring .= '1' . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1);\n        }\n        else {\n            my $t = sprintf('%b', abs($c));\n            $bitstring .= '1' . ('1' x (length($t) - 1)) . '0' . substr($t, 1);\n        }\n\n        if ($v == 1) {\n            $bitstring .= '0';\n        }\n        else {\n            my $t = sprintf('%b', $v);\n            $bitstring .= join('', '1' x (length($t) - 1), '0', substr($t, 1));\n        }\n    }\n\n    pack('B*', $bitstring);\n}\n\nsub RLEE_decoding ($bitstring, $double = 0) {\n\n    open my $fh, '<:raw', \\$bitstring;\n\n    my @values;\n    my $buffer = '';\n    my $len    = 0;\n\n    for (my $k = 0 ; $k <= $len ; ++$k) {\n        my $bit = read_bit($fh, \\$buffer) // last;\n\n        if ($bit eq '0') {\n            push @values, 0;\n        }\n        elsif ($double) {\n            my $bl = 0;\n            ++$bl while (read_bit($fh, \\$buffer) eq '1');\n\n            my $bl2 = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl));\n            my $int = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. ($bl2 - 1)));\n\n            push @values, $int - 1;\n        }\n        else {\n            my $n = 0;\n            ++$n while (read_bit($fh, \\$buffer) eq '1');\n            my $d = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $n));\n            push @values, $d;\n        }\n\n        my $bl = 0;\n        while (read_bit($fh, \\$buffer) == 1) {\n            ++$bl;\n        }\n\n        if ($bl > 0) {\n            my $run = oct('0b1' . join('', map { read_bit($fh, \\$buffer) } 1 .. $bl)) - 1;\n            $k += $run;\n            push @values, ($values[-1]) x $run;\n        }\n\n        if ($k == 0) {\n            $len = pop(@values);\n        }\n    }\n\n    return \\@values;\n}\n\nmy @symbols = (\n               6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,\n               0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 1, 1, 3, 3, 1, 2, 3, 0, 0, 1, 2, 4, 2, 1, 0, 1, 2, 1, 1, 0, 0, 1\n              );\n\nmy $enc = RLEE_encoding([@symbols]);\nmy $dec = RLEE_decoding($enc);\n\nsay unpack('B*', $enc);\nsay \"@$dec\";\n\n\"@$dec\" eq \"@symbols\" or die \"error\";\n\ndo {\n    my @integers = map { int(rand($_)) } 1 .. 1000;\n    my $str      = RLEE_encoding([@integers], 1);\n\n    say \"Encoded length: \", length($str);\n    say \"Rawdata length: \", length(join(' ', @integers));\n\n    my $decoded = RLEE_decoding($str, 1);\n\n    join(' ', @integers) eq join(' ', @$decoded) or die \"Decoding error\";\n\n    {\n        open my $fh, '<:raw', __FILE__;\n        my $str     = do { local $/; <$fh> };\n        my $encoded = RLEE_encoding([unpack('C*', $str)], 1);\n        my $decoded = RLEE_decoding($encoded, 1);\n        $str eq pack('C*', @$decoded) or die \"error\";\n    }\n  }\n\n__END__\n111111100110010111010001111110000000110100010100110110010011000110100100100110001110000110001000010011000101000100100000\n6 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 0 1 1 3 3 1 2 3 0 0 1 2 4 2 1 0 1 2 1 1 0 0 1\nEncoded length: 1867\nRawdata length: 3606\n"
  },
  {
    "path": "Encoding/string_to_integer_encoding_based_on_primes.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 19 March 2021\n# License: GPLv3\n# https://github.com/trizen\n\n# A new text encoding scheme, encoding bytes into a large integer, based on prime numbers.\n\n# Given a string of bytes, the str2int() function returns back an integer that can be unambiguously\n# decoded by the int2str() function back into the original string of bytes, using primes and prime factorization.\n\n# This process becomes very slow for large strings, therefore it's recommended only for small strings (up to 500-1000 bytes).\n\n# The digits 0..9 are encoded as:\n#   853048, 260151, 438257, 1149418, 760322, 517496, 1269824, 885659, 605753, 1019968\n\n# The letters 'a'..'z' are encoded as:\n#   7828810, 1980100, 2040301, 6205356, 2164339, 6558310, 2293305, 5251510, 5396709, 3849553, 10923261, 2637910, 2710731, 6162964, 8510520, 9138039, 6655789, 3094996, 6998519, 9843246, 5140920, 7534364, 7718875, 10354816, 3691599, 14221286\n\n# The codepoints 0..32 are encoded as:\n#   654, 39, 305, 205, 366, 4609, 904, 2710, 1810, 4764, 14864, 4069, 9465, 6315, 29620, 16542, 11034, 45517, 15220, 58775, 66274, 23299, 45025, 30025, 33826, 63532, 70673, 137247, 52230, 57691, 104577, 69729, 124985\n\nuse utf8;\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse open IO => ':utf8';\nuse experimental qw(signatures);\n\nuse List::Util qw(max);\nuse Encode     qw(encode_utf8 decode_utf8);\n\nuse ntheory                qw(vecprod);\nuse Math::Prime::Util::GMP qw(:all);\n\nuse Test::More tests => 3;\n\n# Takes a string of bytes and returns an integer\nsub str2int ($str) {\n\n    my @bytes = unpack('C*', $str);\n    my $base  = 1 + max(1, max(@bytes));\n\n    for (my $k = 1 ; $k < $base ; ++$k) {\n\n        unshift @bytes, $k;\n        push @bytes, 1;\n\n        for (1 .. $k) {\n            my $enc = fromdigits(\\@bytes, ++$base);\n            return vecprod($enc, $base) if is_prime($enc);\n        }\n\n        shift @bytes;\n        pop @bytes;\n    }\n\n    die \"Encoding failed!\";    # should never happen\n}\n\n# Takes an integer, and returns a string of bytes\nsub int2str ($int) {\n    my (@factors) = factor($int);\n\n    my $enc   = pop @factors;\n    my $base  = vecprod(@factors);\n    my @bytes = todigits($enc, $base);\n\n    shift @bytes;\n    pop @bytes;\n\n    pack('C*', @bytes);\n}\n\nis(join(', ', map { int2str(str2int($_)) } 'a' .. 'z'),         join(', ', 'a' .. 'z'));\nis(join(', ', map { int2str(str2int($_)) } 0 .. 255),           join(', ', 0 .. 255));\nis(join(', ', map { ord(int2str(str2int(chr($_)))) } 0 .. 255), join(', ', 0 .. 255));\n\nmy $str = encode_utf8(\"Hello, world! 😃\");\n\nsay str2int($str);\nsay int2str(str2int($str));\n\n__END__\n2020269913412456598059907107141359388654948090049817\nHello, world! 😃\n"
  },
  {
    "path": "Encoding/swap_transform.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 09 November 2024\n# https://github.com/trizen\n\n# A reversible transform, based on swapping of elements.\n\nuse 5.036;\n\nsub swap_transform ($text, $extra = 1) {\n\n    my @bits;\n    my @arr = unpack('C*', $text);\n    my $k   = 0;\n\n    foreach my $i (1 .. $#arr) {\n        if ($arr[$i] < $arr[$i - 1 - $k]) {\n            push @bits, 1;\n            unshift @arr, splice(@arr, $i, 1);\n            ++$k if $extra;\n        }\n        else {\n            push @bits, 0;\n        }\n    }\n\n    return (pack('C*', @arr), \\@bits);\n}\n\nsub reverse_swap_transform ($text, $bits) {\n    my @arr = unpack('C*', $text);\n\n    for (my $i = $#arr ; $i >= 0 ; --$i) {\n        if ($bits->[$i - 1] == 1) {\n            splice(@arr, $i, 0, shift(@arr));\n        }\n    }\n\n    pack('C*', @arr);\n}\n\nforeach my $text (\n    \"TOBEORNOTTOBEORTOBEORNOT\",\n    \"abracadabra\",\n    \"DABDDBBDDBA\",\n    \"CoMpReSSeD\",\n    \"AM SAM. I AM SAM. SAM I AM. THAT SAM-I-AM\",\n    do {\n        open my $fh, '<:raw', __FILE__;\n        local $/;\n        <$fh>;\n    }\n  ) {\n\n    my ($t, $bits) = swap_transform($text);\n    my $rev = reverse_swap_transform($t, $bits);\n\n    if (length($t) < 100) {\n        say $t;\n        say join('', @$bits);\n        say $rev;\n        say '-' x 80;\n    }\n\n    if ($rev ne $text) {\n        die \"Failed for: $text\";\n    }\n}\n\n__END__\nNEBOBNRBOTEOOTTOEORTOROT\n11001100001000011100100\nTOBEORNOTTOBEORTOBEORNOT\n--------------------------------------------------------------------------------\naaaaabrcdbr\n0010101001\nabracadabra\n--------------------------------------------------------------------------------\nABADBDDBDDB\n1000100001\nDABDDBBDDBA\n--------------------------------------------------------------------------------\neSRMCopeSD\n010101010\nCoMpReSSeD\n--------------------------------------------------------------------------------\n--A A . I  .A   .A AMSMIAMSMSAMAMTHTSMIAM\n0101011010010101100011100110010101010100\nAM SAM. I AM SAM. SAM I AM. THAT SAM-I-AM\n--------------------------------------------------------------------------------\n"
  },
  {
    "path": "Encoding/tlen_encoding.pl",
    "content": "#!?usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 04 May 2015\n# Website: https://github.com/trizen\n\n# A very basic length encoder\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Data::Dump qw(pp);\n\n# produce encode and decode dictionary from a tree\nsub walk {\n    my ($node, $code, $h) = @_;\n\n    my $c = $node->[0];\n    if (ref $c) { walk($c->[$_], $code . $_, $h) for 0, 1 }\n    else        { $h->{$c} = $code }\n\n    $h;\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree {\n    my %freq = @_;\n\n    my @nodes = map([$_, $freq{$_}], keys %freq);\n\n    if (@nodes == 1) {\n        return {$nodes[0][0] => '0'};\n    }\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice @nodes, 0, 2;\n        push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub length_encoder {\n    my ($str) = @_;\n\n    my %table;\n    my @chars = split(//, $str);\n\n    my $lim = $#chars;\n\n    my %t;\n    for (my $i = 0 ; $i < $lim ; $i++) {\n        for (my $j = $i + 1 ; $j <= $lim ; $j++) {\n            last if $j + ($j - $i) + 1 > $lim;\n            my $key = join('', @chars[$i .. $j]);\n            if (join('', @chars[$j + 1 .. $j + ($j - $i) + 1]) eq $key) {\n                if (not exists $t{$key}) {\n                    if (exists $t{substr($key, 0, -1)}) {\n                        last;\n                    }\n                    $t{$key} = length($key);\n                }\n                else {\n                    $t{$key}++;\n                }\n            }\n        }\n    }\n\n    my ($dict) = keys(%t) ? mktree(%t) : {};\n    my @sorted_tokens =\n      sort { length($dict->{$a}) <=> length($dict->{$b}) or $t{$b} <=> $t{$a} or $a cmp $b } keys %t;\n\n    say \"Weights: \", pp(\\%t);\n    say \"Sorted: @sorted_tokens\";\n    say \"Bits: \", pp($dict);\n\n    my $regex = do {\n        my @tries = map { \"(?<token>\\Q$_\\E)(?<rest>(?:\\Q$_\\E)*+)\" } @sorted_tokens;\n        local $\" = '|';\n        @sorted_tokens ? qr/^(?:@tries|(?<token>.))/s : qr/^(?<token>.)/s;\n    };\n\n    my @len;\n    my @pos;\n\n    my $dec = '';\n    my $bin = '';\n    my $pos = 0;\n\n    while ($str =~ s/$regex//) {\n        my $m = $+{token};\n        my $r = $+{rest};\n        if (defined $r) {\n            $pos += $-[0];\n            push @pos, $pos;\n            push @len, (1 + length($r) / length($m));\n            $bin .= $dict->{$m};\n        }\n        else {\n            $dec .= $m;\n            ++$pos;\n        }\n    }\n\n    say \"bin: $bin\";\n    say \"pos: @pos\";\n    say \"len: @len\";\n\n    my $bbytes = pack('B*', $bin);\n    my $pbytes = join('', map { chr } @pos);\n    my $lbytes = join('', map { chr } @len);\n\n    return chr(length($bbytes)) . chr(length($bin) % 8) . chr(length($pbytes)) . chr(length($lbytes)) . chr(length($dec)) . $bbytes . $pbytes . $lbytes . $dec;\n}\n\nforeach my $str (\n                 qw(\n                 ABABABAB\n                 ABABABABAAAAAAAAAAAAAFFFFFFFFFFFFFFFFFFFDDDDDDDDDDDDDDDDDDDDJKLABABVADSABABAB\n                 DABDDB DABDDBBDDBA ABBDDD ABRACADABRA TOBEORNOTTOBEORTOBEORNOT\n                 )\n  ) {\n\n    say \"Encoding: $str\";\n    say \"Encoded: \", length_encoder($str);\n    say \"-\" x 80;\n}\n"
  },
  {
    "path": "Encoding/variable_length_run_encoding.pl",
    "content": "#!/usr/bin/perl\n\n# Implementation of the Variable Length Run Encoding.\n\n# Reference:\n#   Data Compression (Summer 2023) - Lecture 5 - Basic Techniques\n#   https://youtube.com/watch?v=TdFWb8mL5Gk\n\nuse 5.036;\n\nsub read_bit ($fh, $bitstring) {\n\n    if (($$bitstring // '') eq '') {\n        $$bitstring = unpack('b*', getc($fh) // return undef);\n    }\n\n    chop($$bitstring);\n}\n\nsub run_length ($arr) {\n\n    @$arr || return [];\n\n    my @result     = [$arr->[0], 1];\n    my $prev_value = $arr->[0];\n\n    foreach my $i (1 .. $#{$arr}) {\n\n        my $curr_value = $arr->[$i];\n\n        if ($curr_value eq $prev_value) {\n            ++$result[-1][1];\n        }\n        else {\n            push(@result, [$curr_value, 1]);\n        }\n\n        $prev_value = $curr_value;\n    }\n\n    return \\@result;\n}\n\nsub VLR_encoding ($bytes) {\n\n    my $bitstream = '';\n    my $rle       = run_length($bytes);\n\n    foreach my $cv (@$rle) {\n        my ($c, $v) = @$cv;\n        $bitstream .= sprintf('%08b', $c);\n        if ($v == 1) {\n            $bitstream .= '0';\n        }\n        else {\n            my $t = sprintf('%b', $v);\n            $bitstream .= join('', '1' x (length($t) - 1), '0', substr($t, 1));\n        }\n    }\n\n    pack('B*', $bitstream);\n}\n\nsub VLR_decoding ($bitstring) {\n\n    my $decoded = '';\n    my $buffer  = '';\n\n    open my $bits_fh, '<:raw', \\$bitstring;\n\n    while (!eof($bits_fh)) {\n\n        my $s = join('', map { read_bit($bits_fh, \\$buffer) } 1 .. 8);\n        my $c = pack('B*', $s);\n\n        my $bl = 0;\n        while (read_bit($bits_fh, \\$buffer) == 1) {\n            ++$bl;\n        }\n\n        $decoded .= $c;\n\n        if ($bl > 0) {\n            $decoded .= $c x (oct('0b1' . join('', map { read_bit($bits_fh, \\$buffer) } 1 .. $bl)) - 1);\n        }\n    }\n\n    $decoded;\n}\n\nmy $str   = join('', 'a' x 13, 'b' x 14, 'c' x 10, 'd' x 3, 'e' x 1, 'f' x 1, 'g' x 4);\nmy @bytes = unpack('C*', $str);\n\nmy $enc = VLR_encoding(\\@bytes);\nmy $dec = VLR_decoding($enc);\n\nsay unpack('B*', $enc);\nsay $dec;\n\n$dec eq $str or die \"error: $dec != $str\";\n"
  },
  {
    "path": "Encryption/RSA_encryption.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 09 January 2017\n# https://github.com/trizen\n\n# A general purpose implementation of the RSA encryption algorithm.\n\nuse utf8;\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse Math::AnyNum qw(:overload gcd irand powmod invmod);\nuse Math::Prime::Util qw(random_strong_prime urandomm);\n\nuse Config qw(%Config);\nuse Getopt::Long qw(GetOptions);\n\nuse constant shortsize => $Config{shortsize};\n\nmy $bits     = 2048;\nmy $decrypt  = 0;\nmy $generate = 0;\nmy $sign     = 0;\n\nmy $public  = 'public.rsa';\nmy $private = 'private.rsa';\n\nmy $in_fh  = \\*STDIN;\nmy $out_fh = \\*STDOUT;\n\nsub usage {\n    print <<\"EOT\";\nusage: $0 [options] [<input] [>output]\n\noptions:\n    -g --generate! : generate the private and public keys\n    -b --bits=i    : size of the prime numbers in bits (default: $bits)\n\n    -d --decrypt!  : decrypt mode (default: ${\\($decrypt ? 'true' : 'false')})\n    -s --sign!     : sign/unsign mode (default: ${\\($sign ? 'true' : 'false')})\n\n    --public=s     : public key file (default: $public)\n    --private=s    : private key file (default: $private)\n\n    -i --input=s   : input file (default: /dev/stdin)\n    -o --output=s  : output file (default: /dev/stdout)\n\n    -h --help      : prints this message\n\nexample:\n    perl $0 --generate\n    perl $0 < input.txt > enc.rsa\n    perl $0 -d < enc.rsa > decoded.txt\nEOT\n    exit;\n}\n\nGetOptions(\n           'bits=i'    => \\$bits,\n           'decrypt!'  => \\$decrypt,\n           'generate!' => \\$generate,\n           'public=s'  => \\$public,\n           'private=s' => \\$private,\n           'input=s'   => \\$in_fh,\n           'sign!'     => \\$sign,\n           'output=s'  => \\$out_fh,\n           'help'      => \\&usage,\n          )\n  or die(\"Error in command line arguments\\n\");\n\nif (!ref($in_fh)) {\n    open my $fh, '<', $in_fh;\n    $in_fh = $fh;\n}\n\nif (!ref($out_fh)) {\n    open my $fh, '>', $out_fh;\n    $out_fh = $fh;\n}\n\nif ($generate) {\n\n    say \"** Generating <<$public>> and <<$private>> files...\";\n\n    # Make sure we have enough bits\n    if ($bits < 128) {\n        $bits = 128;\n    }\n\n    # Make sure `bits` is a power of two\n    if ($bits & ($bits - 1)) {\n        $bits = 2 << (log($bits) / log(2));\n    }\n\n    my $p = Math::AnyNum->new(random_strong_prime($bits));\n    my $q = Math::AnyNum->new(random_strong_prime($bits));\n\n    my $n = $p * $q;\n    my $ϕ = ($p - 1) * ($q - 1);\n\n    # Choosing `e` (part of the public key)\n#<<<\n    my $e;\n    do {\n        say \"** Choosing e...\";\n        $e = irand(65537, $n);\n    } until (\n            $e < $ϕ\n        and gcd($e,     $ϕ    ) == 1\n        and gcd($e - 1, $p - 1) == 2\n        and gcd($e - 1, $q - 1) == 2\n    );\n#>>>\n\n    # Computing `d` (part of the private key)\n    my $d = invmod($e, $ϕ);\n\n    open my $public_fh, '>', $public;\n    print $public_fh \"$bits $e $n\";\n    close $public_fh;\n\n    open my $private_fh, '>', $private;\n    print $private_fh \"$bits $d $n\";\n    close $private_fh;\n\n    say \"** Done!\";\n    exit;\n}\n\nsub decrypt {\n    my ($bits, $d, $n) = map { Math::AnyNum->new($_) } do {\n        open my $fh, '<', $private;\n        split(' ', scalar <$fh>);\n    };\n\n    $bits >>= 2;\n    $bits += shortsize + shortsize;\n\n    while (1) {\n        my $len = read($in_fh, my ($message), $bits) || last;\n\n        my ($s1, $s2, $msg) = unpack('SSb*', $message);\n\n        my $c = Math::AnyNum->new(substr($msg, 0, $s1), 2);\n        my $M = powmod($c, $d, $n);\n\n        print $out_fh pack('b*', substr($M->as_bin, 1, $s2));\n\n        last if $len != $bits;\n    }\n}\n\nsub encrypt {\n    my ($bits, $e, $n) = map { Math::AnyNum->new($_) } do {\n        open my $fh, '<', $public;\n        split(' ', scalar <$fh>);\n    };\n\n    my $L = $bits << 1;\n\n    $bits >>= 2;\n    $bits -= 1;\n\n    while (1) {\n        my $len = read($in_fh, my ($message), $bits) || last;\n\n        my $B = '1' . unpack('b*', $message);\n\n        if ($bits != $len) {\n            $B .= join('', map { urandomm(\"2\") } 1 .. ($L - ($len << 3) - 8));\n        }\n\n        my $m = Math::AnyNum->new($B, 2);\n        my $c = powmod($m, $e, $n);\n        my $bin = $c->as_bin;\n\n        print $out_fh pack(\"SSb$L\", length($bin), $len << 3, $bin);\n\n        last if $len != $bits;\n    }\n}\n\nif ($sign) {\n    ($private, $public) = ($public, $private);\n}\n\nif ($decrypt) {\n    if (not -e $private) {\n        die \"File <<$private>> does not exists! (run --generate)\\n\";\n    }\n    decrypt();\n\n}\nelse {\n    if (not -e $public) {\n        die \"File <<$public>> does not exists! (run --generate)\\n\";\n    }\n    encrypt();\n}\n"
  },
  {
    "path": "Encryption/age-lf.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 02 February 2022\n# Edit: 09 February 2022\n# https://github.com/trizen\n\n# A large file encryption tool, inspired by Age, using Curve25519 and CBC+Serpent for encrypting data.\n\n# See also:\n#   https://github.com/FiloSottile/age\n#   https://metacpan.org/pod/Crypt::CBC\n#   https://metacpan.org/pod/Crypt::PK::X25519\n\n# This is a simplified version of `plage`, optimized for large files:\n#   https://github.com/trizen/perl-scripts/blob/master/Encryption/plage.pl\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Crypt::CBC;\nuse Crypt::PK::X25519;\n\nuse JSON::PP qw(encode_json decode_json);\nuse Getopt::Long qw(GetOptions :config no_ignore_case);\n\nbinmode(STDIN,  ':raw');\nbinmode(STDOUT, ':raw');\n\nuse constant {\n              SHORT_APPNAME   => \"age-lf\",\n              BUFFER_SIZE     => 1024 * 1024,\n              EXPORT_KEY_BASE => 62,\n              VERSION         => '0.01',\n             };\n\nmy %CONFIG = (\n              cipher     => 'Serpent',\n              chain_mode => 'CBC',\n             );\n\nsub create_cipher ($pass, $cipher = $CONFIG{cipher}, $chain_mode = $CONFIG{chain_mode}) {\n    Crypt::CBC->new(\n                    -pass       => $pass,\n                    -cipher     => 'Cipher::' . $cipher,\n                    -chain_mode => lc($chain_mode),\n                    -pbkdf      => 'pbkdf2',\n                   );\n}\n\nsub x25519_from_public ($hex_key) {\n    Crypt::PK::X25519->new->import_key(\n                                       {\n                                        curve => \"x25519\",\n                                        pub   => $hex_key,\n                                       }\n                                      );\n}\n\nsub x25519_from_private ($hex_key) {\n    Crypt::PK::X25519->new->import_key(\n                                       {\n                                        curve => \"x25519\",\n                                        priv  => $hex_key,\n                                       }\n                                      );\n}\n\nsub x25519_random_key {\n    while (1) {\n        my $key  = Crypt::PK::X25519->new->generate_key;\n        my $hash = $key->key2hash;\n\n        next if substr($hash->{pub},  0, 1) eq '0';\n        next if substr($hash->{priv}, 0, 1) eq '0';\n\n        next if substr($hash->{pub},  -1) eq '0';\n        next if substr($hash->{priv}, -1) eq '0';\n\n        return $key;\n    }\n}\n\nsub encrypt ($fh, $public_key) {\n\n    # Generate a random ephemeral key-pair.\n    my $random_ephem_key = x25519_random_key();\n\n    # Create a shared secret, using the random key and the reciever's public key\n    my $shared_secret = $random_ephem_key->shared_secret($public_key);\n\n    my $cipher    = create_cipher($shared_secret);\n    my $ephem_pub = $random_ephem_key->key2hash->{pub};\n    my $dest_pub  = $public_key->key2hash->{pub};\n\n    my %info = (\n                dest       => $dest_pub,\n                cipher     => $CONFIG{cipher},\n                chain_mode => $CONFIG{chain_mode},\n                ephem_pub  => $ephem_pub,\n               );\n\n    my $json = encode_json(\\%info);\n    syswrite(STDOUT, pack(\"N*\", length($json)));\n    syswrite(STDOUT, $json);\n\n    $cipher->start('encrypting');\n\n    while (sysread($fh, (my $buffer), BUFFER_SIZE)) {\n        syswrite(STDOUT, $cipher->crypt($buffer) // '');\n    }\n\n    syswrite(STDOUT, $cipher->finish);\n}\n\nsub decrypt ($fh, $private_key) {\n\n    if (not defined $private_key) {\n        die \"No private key provided!\\n\";\n    }\n\n    if (ref($private_key) ne 'Crypt::PK::X25519') {\n        die \"Invalid private key!\\n\";\n    }\n\n    sysread($fh, (my $json_length), 32 >> 3);\n    sysread($fh, (my $json),        unpack(\"N*\", $json_length));\n\n    my $enc = decode_json($json);\n\n    # Make sure the private key is correct\n    if ($enc->{dest} ne $private_key->key2hash->{pub}) {\n        die \"Incorrect private key!\\n\";\n    }\n\n    # The ephemeral public key\n    my $ephem_pub = $enc->{ephem_pub};\n\n    # Import the public key\n    my $ephem_pub_key = x25519_from_public($ephem_pub);\n\n    # Recover the shared secret\n    my $shared_secret = $private_key->shared_secret($ephem_pub_key);\n\n    # Create the cipher\n    my $cipher = create_cipher($shared_secret, $enc->{cipher}, $enc->{chain_mode});\n\n    $cipher->start('decrypting');\n\n    while (sysread($fh, (my $buffer), BUFFER_SIZE)) {\n        syswrite(STDOUT, $cipher->crypt($buffer) // '');\n    }\n\n    syswrite(STDOUT, $cipher->finish);\n}\n\nsub export_key ($x_public_key) {\n    require Math::BigInt;\n    Math::BigInt->from_hex($x_public_key)->to_base(EXPORT_KEY_BASE);\n}\n\nsub decode_exported_key ($public_key) {\n    require Math::BigInt;\n    Math::BigInt->from_base($public_key, EXPORT_KEY_BASE)->to_hex;\n}\n\nsub decode_public_key ($key) {\n    x25519_from_public(decode_exported_key($key));\n}\n\nsub decode_private_key ($file) {\n\n    if (not -T $file) {\n        die \"Invalid key file!\\n\";\n    }\n\n    open(my $fh, '<:utf8', $file)\n      or die \"Can't open file <<$file>>: $!\";\n\n    local $/;\n    my $key = decode_json(<$fh>);\n    x25519_from_private(decode_exported_key($key->{x_priv}));\n}\n\nsub generate_new_key {\n\n    my $x25519_key = x25519_random_key();\n    my $x_key      = $x25519_key->key2hash;\n\n    my $x_public_key  = $x_key->{pub};\n    my $x_private_key = $x_key->{priv};\n\n    my %info = (\n                x_pub  => export_key($x_public_key),\n                x_priv => export_key($x_private_key),\n               );\n\n    say encode_json(\\%info);\n    warn sprintf(\"Public key: %s\\n\", $info{x_pub});\n    return 1;\n}\n\nsub help ($exit_code) {\n\n    local $\" = \" \";\n\n    my @chaining_modes = map { uc } qw(cbc pcbc cfb ofb ctr);\n\n    my @valid_ciphers = sort grep {\n        eval { require \"Crypt/Cipher/$_.pm\"; 1 };\n      } qw(\n      AES Anubis Twofish Camellia Serpent SAFERP\n      );\n\n    print <<\"EOT\";\nusage: $0 [options] [<input] [>output]\n\nEncryption and signing:\n\n    -g --generate-key   : Generate a new key-pair\n    -e --encrypt=key    : Encrypt data with a given public key\n    -d --decrypt=key    : Decrypt data with a given private key file\n       --cipher=s       : Change the symmetric cipher (default: $CONFIG{cipher})\n                          valid: @valid_ciphers\n       --chain-mode=s   : Change the chaining mode (default: $CONFIG{chain_mode})\n                          valid: @chaining_modes\n\nExamples:\n\n    # Generate a key-pair\n    $0 -g > key.txt\n\n    # Encrypt a message for Alice\n    $0 -e=RBZ17knALkL5N1AWYjAgBwZDpQpQmvLbuTphVAx7XQC < message.txt > message.enc\n\n    # Decrypt a received message\n    $0 -d=key.txt < message.enc > message.txt\nEOT\n\n    exit($exit_code);\n}\n\nsub version {\n\n    my $width = 20;\n\n    printf(\"%-*s %s\\n\", $width, SHORT_APPNAME,        VERSION);\n    printf(\"%-*s %s\\n\", $width, 'Crypt::CBC',         $Crypt::CBC::VERSION);\n    printf(\"%-*s %s\\n\", $width, 'Crypt::PK::X25519',  $Crypt::PK::X25519::VERSION);\n    printf(\"%-*s %s\\n\", $width, 'Crypt::PK::Ed25519', $Crypt::PK::Ed25519::VERSION);\n\n    exit(0);\n}\n\nGetOptions(\n           'cipher=s'          => \\$CONFIG{cipher},\n           'chain-mode|mode=s' => \\$CONFIG{chain_mode},\n           'g|generate-key!'   => \\$CONFIG{generate_key},\n           'e|encrypt=s'       => \\$CONFIG{encrypt},\n           'd|decrypt=s'       => \\$CONFIG{decrypt},\n           'v|version'         => \\&version,\n           'h|help'            => sub { help(0) },\n          )\n  or die(\"Error in command line arguments\\n\");\n\nif ($CONFIG{generate_key}) {\n    generate_new_key();\n    exit 0;\n}\n\nsub get_input_fh {\n    my $fh = \\*STDIN;\n\n    if (@ARGV and -t $fh) {\n        sysopen(my $file_fh, $ARGV[0], 0)\n          or die \"Can't open file <<$ARGV[0]>> for reading: $!\";\n        return $file_fh;\n    }\n\n    return $fh;\n}\n\nif (defined($CONFIG{encrypt})) {\n    my $x_pub = decode_public_key($CONFIG{encrypt});\n    encrypt(get_input_fh(), $x_pub);\n    exit 0;\n}\n\nif (defined($CONFIG{decrypt})) {\n    my $x_priv = decode_private_key($CONFIG{decrypt});\n    decrypt(get_input_fh(), $x_priv);\n    exit 0;\n}\n\nhelp(1);\n"
  },
  {
    "path": "Encryption/backdoored_rsa_with_x25519.pl",
    "content": "#!/usr/bin/perl\n\n# RSA key generation, backdoored using curve25519.\n\n# Inspired by:\n#   https://gist.github.com/ryancdotorg/18235723e926be0afbdd\n\n# See also:\n#   https://eprint.iacr.org/2002/183.pdf\n#   https://www.reddit.com/r/crypto/comments/2ss1v5/rsa_key_generation_backdoored_using_curve25519/\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse ntheory qw(:all);\nuse Crypt::PK::X25519;\n\nsub generate_rsa_key ($bits = 2048, $ephem_pub = \"\", $pos = 80, $seed = undef) {\n\n    if (defined($seed)) {\n        csrand($seed);\n    }\n\n    my $p = random_strong_prime($bits >> 1);\n    my $q = random_strong_prime($bits >> 1);\n\n    if ($p > $q) {\n        ($p, $q) = ($q, $p);\n    }\n\n    my $n = ($p * $q);\n\n    # Embed the public key into the modulus\n    my $n_hex = todigitstring($n, 16);\n    substr($n_hex, $pos, length($ephem_pub), $ephem_pub);\n\n    # Recompute n, reusing p in computing a new q\n    $n = fromdigits($n_hex, 16);\n    $q = next_prime(divint($n, $p));\n    $n = $p * $q;\n\n    my $phi = ($p - 1) * ($q - 1);\n\n    my $e = 0;\n    for (my $k = 16 ; gcd($e, $phi) != 1 ; ++$k) {\n        $e = 2**$k + 1;\n    }\n\n    my $d = invmod($e, $phi);\n\n    return\n      scalar {\n              e => $e,\n              p => $p,\n              q => $q,\n              d => $d,\n              n => $n,\n             };\n}\n\nsub recover_rsa_key ($bits, $n, $master_private_key, $pos) {\n\n    my $n_hex     = todigitstring($n, 16);\n    my $ephem_pub = substr($n_hex, $pos, 64);    # extract the embeded public key\n\n    # Import the public key\n    my $ephem_pub_key = Crypt::PK::X25519->new->import_key(\n                                                           {\n                                                            curve => \"x25519\",\n                                                            pub   => $ephem_pub,\n                                                           }\n                                                          );\n\n    # Import the master private key\n    my $master_priv_key = Crypt::PK::X25519->new->import_key(\n                                                             {\n                                                              curve => \"x25519\",\n                                                              priv  => $master_private_key,\n                                                             }\n                                                            );\n\n    # Recover the shared secret that was used as a seed value for the random number generator\n    my $recovered_secret = $master_priv_key->shared_secret($ephem_pub_key);\n\n    # Recompute the RSA key, given the embeded public key and the seed value\n    generate_rsa_key($bits, $ephem_pub, $pos, $recovered_secret);\n}\n\nmy $BITS = 2048;            # must be >= 1024\nmy $POS  = $BITS >> 5;\n\n# Public and private master keys\nmy $MASTER_PUBLIC  = \"c10811d4e424305c6696f9b5f787efb67f80530e6115e367bd7967ba05093e3d\";\nmy $MASTER_PRIVATE = \"3a35b10511bcd20bcb9b12bd73ab9ad0bf8f7f469ffb70d2ae8fb110b761df97\";\n\n# Generate a random ephemeral key-pair. The private key will be used in creating\n# the shared secret, while the public key will be embeded in the RSA modulus.\nmy $random_ephem_key = Crypt::PK::X25519->new->generate_key;\n\n# Import the master public key\nmy $master_public_key = Crypt::PK::X25519->new->import_key(\n                                                           {\n                                                            curve => \"x25519\",\n                                                            pub   => $MASTER_PUBLIC,\n                                                           }\n                                                          );\n\nmy $ephem_pub     = $random_ephem_key->key2hash->{pub};\nmy $shared_secret = $random_ephem_key->shared_secret($master_public_key);\n\n# Generate the backdoored RSA key, using the ephemeral random public key, which will be embeded\n# in the RSA modulus, and pass the shared secret value as a seed for the random number generator.\nmy $rsa_key = generate_rsa_key($BITS, $ephem_pub, $POS, $shared_secret);\n\nmy $message = \"Hello, world!\";\nmy $m       = fromdigits(unpack(\"H*\", $message), 16);    # message\n\nif ($m >= $rsa_key->{n}) {\n    die \"Message is too long!\";\n}\n\nmy $c = powmod($m, $rsa_key->{e}, $rsa_key->{n});        # encoded message\nmy $M = powmod($c, $rsa_key->{d}, $rsa_key->{n});        # decoded message\n\nsay pack(\"H*\", todigitstring($M, 16));\n\n# Recover the RSA key, given the RSA modulus n and the private master key.\nmy $recovered_rsa = recover_rsa_key($BITS, $rsa_key->{n}, $MASTER_PRIVATE, $POS);\n\n# Decode the encrypted message, using the recovered RSA key\nmy $decoded_message = powmod($c, $recovered_rsa->{d}, $rsa_key->{n});\n\n# Print the decoded message, decoded with the recovered key\nsay pack(\"H*\", todigitstring($decoded_message, 16));\n"
  },
  {
    "path": "Encryption/cbc+xor_file_encrypter.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 18 March 2022\n# https://github.com/trizen\n\n# A simple file encryption cihpher, using XOR with SHA-512 of the key and substring shuffling.\n\n# WARNING: should NOT be used for encrypting real-world data.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Block_cipher\n#   https://en.wikipedia.org/wiki/XOR_cipher\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nbinmode(STDOUT, ':raw');\n\npackage SimpleXORCipher {\n\n    require Digest::SHA;\n\n    sub new ($class, %opt) {\n\n        $opt{rounds} ||= 1;\n\n        if (!defined($opt{key})) {\n            die \"Undefined key parameter\";\n        }\n\n        if ($opt{rounds} <= 0) {\n            die \"Number of rounds must be > 0\";\n        }\n\n        $opt{key} = Digest::SHA::sha512($opt{key});\n\n        bless \\%opt, $class;\n    }\n\n    sub encrypt ($self, $str) {\n\n        my $key = $self->{key};\n        $str ^= $key;\n\n        my $i = my $l = length($str);\n\n        for my $k (1 .. $self->{rounds}) {\n            $str =~ s/(.{$i})(.)/$2$1/sg while (--$i > 0);\n            $str ^= Digest::SHA::sha512($key . $k);\n            $str =~ s/(.{$i})(.)/$2$1/sg while (++$i < $l);\n            $str ^= Digest::SHA::sha512($k . $key);\n        }\n\n        return $str;\n    }\n\n    sub decrypt ($self, $str) {\n\n        my $key = $self->{key};\n\n        my $i = my $l = length($str);\n\n        for my $k (reverse(1 .. $self->{rounds})) {\n            $str ^= Digest::SHA::sha512($k . $key);\n            $str =~ s/(.)(.{$i})/$2$1/sg while (--$i > 0);\n            $str ^= Digest::SHA::sha512($key . $k);\n            $str =~ s/(.)(.{$i})/$2$1/sg while (++$i < $l);\n        }\n\n        $str ^= $key;\n        return $str;\n    }\n\n    sub cbc_encrypt ($crypt, $iv, $result, $blocks) {\n        my ($i, $r) = ($$iv, $$result);\n        foreach (@$blocks) {\n            $r .= $i = $crypt->encrypt($i ^ $_);\n        }\n        ($$iv, $$result) = ($i, $r);\n    }\n\n    sub cbc_decrypt ($crypt, $iv, $result, $blocks) {\n        my ($i, $r) = ($$iv, $$result);\n        foreach (@$blocks) {\n            $r .= $i ^ $crypt->decrypt($_);\n            $i = $_;\n        }\n        ($$iv, $$result) = ($i, $r);\n    }\n\n    sub generate_iv ($self) {\n        my $iv = Digest::SHA::sha512($self->{key});\n        foreach my $i (1 .. $self->{rounds}) {\n            $iv = Digest::SHA::sha512(($i % 2 == 0) ? $iv : scalar(reverse($iv)));\n        }\n        return $iv;\n    }\n}\n\nuse constant {BUFFER_SIZE => 1024 * 10,};\n\nsub encrypt_file ($file, $key) {\n\n    my $crypt = SimpleXORCipher->new(key => $key);\n    my $iv    = $crypt->generate_iv;\n\n    open(my $fh, '<:raw', $file)\n      or die \"can't open file <<$file>> for reading: $!\";\n\n    my $size = -s $file;\n    $crypt->cbc_encrypt(\\$iv, \\(my $size_enc), [pack(\"N*\", $size)]);\n    print $size_enc;\n\n    my $key_size = length($crypt->{key});\n\n    while (read($fh, (my $buffer), BUFFER_SIZE)) {\n        my @blocks = unpack(\"(a$key_size)*\", $buffer);\n        $crypt->cbc_encrypt(\\$iv, \\(my $result), \\@blocks);\n        print $result;\n    }\n\n    close $fh;\n}\n\nsub decrypt_file ($file, $key) {\n\n    my $crypt    = SimpleXORCipher->new(key => $key);\n    my $iv       = $crypt->generate_iv;\n    my $key_size = length($crypt->{key});\n\n    open(my $fh, '<:raw', $file)\n      or die \"can't open file <<$file>> for reading: $!\";\n\n    read($fh, (my $size), $key_size);\n\n    $crypt->cbc_decrypt(\\$iv, \\(my $size_dec), [$size]);\n    $size = unpack(\"N*\", substr($size_dec, 0, 4));\n\n    my $dec_size = 0;\n\n    while (read($fh, (my $buffer), BUFFER_SIZE)) {\n        my @blocks = unpack(\"(a$key_size)*\", $buffer);\n\n        $crypt->cbc_decrypt(\\$iv, \\(my $result), \\@blocks);\n        $dec_size += $key_size * scalar(@blocks);\n\n        if ($dec_size > $size) {\n            print substr($result, 0, (scalar(@blocks) - 1) * $key_size, '');\n            print substr($result, 0,                                    $size % $key_size);\n            last;\n        }\n        else {\n            print $result;\n        }\n    }\n\n    close $fh;\n}\n\nsub help ($exit_code = 0) {\n    print <<\"EOT\";\nusage: $0 [options] [input file]\n\noptions:\n\n    -k  --key=s    : encryption/decryption symmetric key\n    -d  --decrypt  : decryption mode\n    -h  --help     : print this message\n\nexample:\n\n    # Encrypt file\n    perl $0 -k=foo msg.txt > msg.enc\n\n    # Decrypt file\n    perl $0 -d -k=foo msg.enc > msg.dec\nEOT\n\n    exit($exit_code);\n}\n\nuse Getopt::Long qw(GetOptions);\n\nmy $key     = undef;\nmy $decrypt = 0;\n\nGetOptions(\n           \"d|decrypt\" => \\$decrypt,\n           \"key=s\"     => \\$key,\n           \"h|help\"    => sub { help(0) },\n          )\n  or die(\"Error in command line arguments\\n\");\n\nmy $input_file = $ARGV[0] // help(2);\n\nif ($decrypt) {\n    decrypt_file($input_file, $key);\n}\nelse {\n    encrypt_file($input_file, $key);\n}\n"
  },
  {
    "path": "Encryption/crypt_rsa.pl",
    "content": "#!/usr/bin/perl\n\n# Using Crypt::RSA with a specific private key.\n\nuse 5.014;\nuse Crypt::RSA;\n\nmy $rsa = Crypt::RSA->new;\nmy $key = Crypt::RSA::Key->new;\n\nmy ($public, $private) =\n  $key->generate(\n                 p => \"94424081139901371883469166542407095517576260048697655243\",\n                 q => \"79084622052242264844238683495727691663247340251867615781\",\n                 e => 65537,\n                )\n  or die \"error\";\n\nmy $cyphertext = $rsa->encrypt(\n                               Message => \"Hello world!\",\n                               Key     => $public,\n                               Armour  => 1,\n                              )\n  || die $rsa->errstr();\n\nsay $cyphertext;\n\nmy $plaintext = $rsa->decrypt(\n                              Cyphertext => $cyphertext,\n                              Key        => $private,\n                              Armour     => 1,\n                             )\n  || die $rsa->errstr();\n\nsay $plaintext;\n"
  },
  {
    "path": "Encryption/one-time_pad.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 13 November 2016\n# https://github.com/trizen\n\n# One-time pad symmetric encryption, where the key is pseudo-randomly generated from a given seed.\n\n# See also:\n#   https://en.wikipedia.org/wiki/One-time_pad\n\n#---------------------------------------------------\n#                !!! WARNING !!!\n#---------------------------------------------------\n# This program is just a proof-of-concept.\n# Do NOT use this program to encrypt sensitive data!\n#---------------------------------------------------\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Getopt::Std qw(getopts);\n\nmy %opts;\ngetopts('s:h', \\%opts);\n\nuse constant {\n              READ_SIZE => 2 * 1024**2,    # 2 MB\n             };\n\nsub usage {\n    warn \"\\n[ERROR]: \", @_, \"\\n\\n\" if @_;\n    print <<\"USAGE\";\nusage: $0 [options] [<input] [>output]\n\noptions:\n        -s SEED   : random seed\n\nexample:\n    $0 -s 42 < input.txt > output.dat\n\nUSAGE\n    exit 1;\n}\n\n$opts{h} && usage();\n\nencode_file(\n            in_fh  => \\*STDIN,\n            out_fh => \\*STDOUT,\n            seed   => defined($opts{s}) ? $opts{s} : usage(\"No seed specified!\"),\n           );\n\nsub generate_key {\n    my ($length) = @_;\n    pack('C*', map { int(rand(256)) } 1 .. $length);\n}\n\nsub encode_file {\n    my %args = @_;\n\n    srand($args{seed});\n\n    while (1) {\n        my $len = read($args{in_fh}, my ($chunk), READ_SIZE);\n        my $key = generate_key($len);\n\n        print {$args{out_fh}} $chunk ^ $key;\n        last if $len != READ_SIZE;\n    }\n\n    return 1;\n}\n"
  },
  {
    "path": "Encryption/plage.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 02 February 2022\n# Edit: 09 February 2022\n# https://github.com/trizen\n\n# A message encryption tool, inspired by Age and GnuPG, using Curve25519 and CBC+Serpent for encrypting data.\n\n# Main features include:\n#   - ASCII armor\n#   - generation of X25519 and Ed25519 key-pairs\n#   - encryption and decryption of messages\n#   - signing and verification of signatures\n#   - compression support\n#   - import and export of public keys\n#   - local encryption of private keys\n#   - local keyring, similar to PGP\n#   - support for various modern ciphers, like: Serpent (default), Twofish, AES, etc.\n#   - support for various chaining modes, like: CBC (default), PCBC, CFB, OFB, CTR.\n\n# See also:\n#   https://github.com/FiloSottile/age\n#   https://metacpan.org/pod/Crypt::CBC\n#   https://metacpan.org/pod/Crypt::PK::X25519\n#   https://metacpan.org/pod/Crypt::PK::Ed25519\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nno warnings 'once';\nuse experimental qw(signatures);\n\nuse Crypt::CBC;\n\nuse Digest::SHA qw(sha256);\nuse Crypt::PK::X25519;\nuse Crypt::PK::Ed25519;\n\nuse Term::UI;\nuse Term::ReadLine;\nuse Term::ReadKey qw(ReadMode);\n\nuse JSON::PP qw(encode_json decode_json);\nuse Getopt::Long qw(GetOptions :config no_ignore_case);\nuse MIME::Base64 qw(encode_base64 decode_base64);\nuse File::Spec::Functions qw(catdir catfile curdir);\nuse Storable qw(store retrieve);\n\nuse constant {\n              SHORT_APPNAME            => \"plage\",\n              JSON_LENGTH_WIDTH        => 6,\n              USER_ID_SIZE             => 32,\n              HASH_SIZE                => 32,\n              PK_HEX_SIZE              => 64,\n              SIGNATURE_SIZE           => 64,\n              EXPORT_KEY_BASE          => 62,\n              PASSPHRASE_CIPHER        => 'Serpent',\n              PASSPHRASE_CHAINING_MODE => 'CBC',\n              VERSION                  => '0.01',\n             };\n\nmy $term = Term::ReadLine->new(SHORT_APPNAME);\n\nmy $plage_dir = catdir(get_config_dir(), SHORT_APPNAME);\n\nif (not -d $plage_dir) {\n    require File::Path;\n    File::Path::make_path($plage_dir)\n      or die \"Can't create directory: $plage_dir\";\n}\n\nmy $keyring_file = catfile($plage_dir, 'keys.dat');\n\nif (not -f $keyring_file) {\n    store(\n          {\n           version => VERSION,\n          },\n          $keyring_file\n         );\n}\n\nmy %KEYRING = %{retrieve($keyring_file)};\n\nmy %CONFIG = (\n              cipher          => 'Serpent',\n              chain_mode      => 'CBC',\n              sign            => 0,\n              compress        => 1,\n              compress_method => 'gzip',\n             );\n\nmy %COMPRESSION_METHODS = (\n                           gzip  => \\&gzip_compress_data,\n                           zstd  => \\&zstd_compress_data,\n                           zip   => \\&zip_compress_data,\n                           xz    => \\&xz_compress_data,\n                           bzip2 => \\&bzip2_compress_data,\n                           lzop  => \\&lzop_compress_data,\n                           lzf   => \\&lzf_compress_data,\n                           lzip  => \\&lzip_compress_data,\n                          );\n\nsub create_cipher ($pass, $cipher = $CONFIG{cipher}, $chain_mode = $CONFIG{chain_mode}) {\n    Crypt::CBC->new(\n                    -pass       => $pass,\n                    -cipher     => 'Cipher::' . $cipher,\n                    -chain_mode => lc($chain_mode),\n                    -pbkdf      => 'pbkdf2',\n                   );\n}\n\nsub get_config_dir {\n\n    my $xdg_config_home = $ENV{XDG_CONFIG_HOME};\n\n    if ($xdg_config_home and -d -w $xdg_config_home) {\n        return $xdg_config_home;\n    }\n\n    my $home_dir =\n         $ENV{HOME}\n      || $ENV{LOGDIR}\n      || (($^O eq 'MSWin32') ? '\\Local Settings\\Application Data' : ((getpwuid($<))[7] || `echo -n ~`));\n\n    if (not -d -w $home_dir) {\n        $home_dir = curdir();\n    }\n\n    return catdir($home_dir, '.config');\n}\n\nsub x25519_from_public ($hex_key) {\n    Crypt::PK::X25519->new->import_key(\n                                       {\n                                        curve => \"x25519\",\n                                        pub   => $hex_key,\n                                       }\n                                      );\n}\n\nsub ed25519_from_public ($hex_key) {\n    Crypt::PK::Ed25519->new->import_key(\n                                        {\n                                         curve => \"ed25519\",\n                                         pub   => $hex_key,\n                                        }\n                                       );\n}\n\nsub ed25519_from_private ($hex_key) {\n    Crypt::PK::Ed25519->new->import_key(\n                                        {\n                                         curve => \"ed25519\",\n                                         priv  => $hex_key,\n                                        }\n                                       );\n}\n\nsub x25519_from_private ($hex_key) {\n    Crypt::PK::X25519->new->import_key(\n                                       {\n                                        curve => \"x25519\",\n                                        priv  => $hex_key,\n                                       }\n                                      );\n}\n\nsub x25519_from_private_raw ($raw_key) {\n    Crypt::PK::X25519->new->import_key_raw($raw_key, 'private');\n}\n\nsub ed25519_from_private_raw ($raw_key) {\n    Crypt::PK::Ed25519->new->import_key_raw($raw_key, 'private');\n}\n\nsub x25519_random_key {\n    while (1) {\n        my $key  = Crypt::PK::X25519->new->generate_key;\n        my $hash = $key->key2hash;\n\n        next if substr($hash->{pub},  0, 1) eq '0';\n        next if substr($hash->{priv}, 0, 1) eq '0';\n\n        next if substr($hash->{pub},  -1) eq '0';\n        next if substr($hash->{priv}, -1) eq '0';\n\n        return $key;\n    }\n}\n\nsub ed25519_random_key {\n    while (1) {\n        my $key  = Crypt::PK::Ed25519->new->generate_key;\n        my $hash = $key->key2hash;\n\n        next if substr($hash->{pub},  0, 1) eq '0';\n        next if substr($hash->{priv}, 0, 1) eq '0';\n\n        next if substr($hash->{pub},  -1) eq '0';\n        next if substr($hash->{priv}, -1) eq '0';\n\n        return $key;\n    }\n}\n\nsub uncompress_data ($data) {\n    require IO::Uncompress::AnyUncompress;\n    IO::Uncompress::AnyUncompress::anyuncompress(\\$data, \\my $uncompressed)\n      or die \"anyuncompress failed: $IO::Uncompress::AnyUncompress::AnyUncompressError\\n\";\n    return $uncompressed;\n}\n\nsub gzip_compress_data ($data) {\n    require IO::Compress::Gzip;\n    IO::Compress::Gzip::gzip(\\$data, \\my $compressed)\n      or die \"gzip failed: $IO::Compress::Gzip::GzipError\\n\";\n    return $compressed;\n}\n\nsub zip_compress_data ($data) {\n    require IO::Compress::Zip;\n    IO::Compress::Zip::zip(\\$data, \\my $compressed)\n      or die \"zip failed: $IO::Compress::Zip::ZipError\\n\";\n    return $compressed;\n}\n\nsub lzop_compress_data ($data) {\n    require IO::Compress::Lzop;\n    IO::Compress::Lzop::lzop(\\$data, \\my $compressed)\n      or die \"lzop failed: $IO::Compress::Lzop::LzopError\\n\";\n    return $compressed;\n}\n\nsub lzip_compress_data ($data) {\n    require IO::Compress::Lzip;\n    IO::Compress::Lzip::lzip(\\$data, \\my $compressed)\n      or die \"lzop failed: $IO::Compress::Lzip::LzipError\\n\";\n    return $compressed;\n}\n\nsub lzf_compress_data ($data) {\n    require IO::Compress::Lzf;\n    IO::Compress::Lzf::lzf(\\$data, \\my $compressed)\n      or die \"lzop failed: $IO::Compress::Lzf::LzfError\\n\";\n    return $compressed;\n}\n\nsub bzip2_compress_data ($data) {\n    require IO::Compress::Bzip2;\n    IO::Compress::Bzip2::bzip2(\\$data, \\my $compressed)\n      or die \"bzip2 failed: $IO::Compress::Bzip2::Bzip2Error\\n\";\n    return $compressed;\n}\n\nsub xz_compress_data ($data) {\n    require IO::Compress::Xz;\n    IO::Compress::Xz::xz(\\$data, \\my $compressed)\n      or die \"xz failed: $IO::Compress::Xz::XzError\\n\";\n    return $compressed;\n}\n\nsub zstd_compress_data ($data) {\n    require IO::Compress::Zstd;\n    IO::Compress::Zstd::zstd(\\$data, \\my $compressed)\n      or die \"zstd failed: $IO::Compress::Zstd::ZstdError\\n\";\n    return $compressed;\n}\n\nsub sign_message ($data, $signature_private_key) {\n    $signature_private_key->sign_message($data);\n}\n\nsub verify_signature ($data, $signature, $signature_public_key) {\n    $signature_public_key->verify_message($signature, $data);\n}\n\nsub encrypt ($data, $public_key) {\n\n    # Generate a random ephemeral key-pair.\n    my $random_ephem_key = x25519_random_key();\n\n    # Create a shared secret, using the random key and the reciever's public key\n    my $shared_secret = $random_ephem_key->shared_secret($public_key);\n\n    if ($CONFIG{compress}) {\n        $data = $COMPRESSION_METHODS{$CONFIG{compress_method}}($data);\n    }\n\n    my $cipher     = create_cipher($shared_secret);\n    my $ciphertext = $cipher->encrypt($data);\n    my $ephem_pub  = $random_ephem_key->key2hash->{pub};\n    my $dest_pub   = $public_key->key2hash->{pub};\n\n    return {\n            time       => time,\n            dest       => $dest_pub,\n            cipher     => $CONFIG{cipher},\n            chain_mode => $CONFIG{chain_mode},\n            compressed => $CONFIG{compress},\n            ephem_pub  => $ephem_pub,\n            ciphertext => $ciphertext,\n           };\n}\n\nsub decrypt ($enc, $private_key) {\n\n    if (not defined $private_key) {\n        die \"No private key provided!\\n\";\n    }\n\n    if (ref($private_key) ne 'Crypt::PK::X25519') {\n        die \"Invalid private key!\\n\";\n    }\n\n    my $ephem_pub  = $enc->{ephem_pub};\n    my $ciphertext = $enc->{ciphertext};\n\n    # Import the public key\n    my $ephem_pub_key = x25519_from_public($ephem_pub);\n\n    # Recover the shared secret\n    my $shared_secret = $private_key->shared_secret($ephem_pub_key);\n\n    my $cipher = create_cipher($shared_secret, $enc->{cipher}, $enc->{chain_mode});\n    my $data   = $cipher->decrypt($ciphertext);\n\n    if ($enc->{compressed}) {\n        $data = uncompress_data($data);\n    }\n\n    return $data;\n}\n\nsub create_clear_signed_message ($text, $ed_private_key) {\n\n    if (not defined $ed_private_key) {\n        die \"No signature key provided!\\n\";\n    }\n\n    if (ref($ed_private_key) ne 'Crypt::PK::Ed25519') {\n        die \"Invalid signature key provided!\\n\";\n    }\n\n    my $signed_message = \"-----BEGIN PLAGE SIGNED MESSAGE-----\\n\";\n\n    $text .= \"\\n\";\n\n    my $signature = sign_message($text, $ed_private_key);\n\n    $signed_message .= ($text =~ s/^/ /mgr);\n    $signed_message .= \"-----BEGIN PLAGE SIGNATURE-----\\n\";\n\n    my $ed_pub = $ed_private_key->key2hash->{pub};\n\n    my %info = (\n                time   => time,\n                sig    => encode_base64($signature),\n                ed_pub => $ed_pub,\n                x_pub  => $KEYRING{keys}{Ed25519}{$ed_pub}{x_pub},\n               );\n\n    my $json_data = encode_json(\\%info);\n    my $sha256    = sha256($json_data);\n\n    $signed_message .= encode_base64($sha256 . sign_message($sha256, $ed_private_key) . $json_data);\n    $signed_message .= \"-----END PLAGE SIGNATURE-----\\n\";\n\n    return $signed_message;\n}\n\nsub get_user_info_for_ed25519_public ($ed_pub) {\n    $KEYRING{keys}{Ed25519}{$ed_pub};\n}\n\nsub verify_clear_signed_message ($message, $callback = sub { print $_[0] }) {\n\n    my $collect_msg = 0;\n    my $collect_sig = 0;\n\n    my $msg        = '';\n    my $base64_sig = '';\n\n    open my $fh, '<:raw', \\$message;\n    while (defined(my $line = <$fh>)) {\n        if ($line =~ /^-----BEGIN PLAGE SIGNED MESSAGE-----\\s*\\z/) {\n            $collect_msg = 1;\n        }\n        elsif ($line =~ /^-----BEGIN PLAGE SIGNATURE-----\\s*\\z/) {\n            $collect_sig = 1;\n            $collect_msg = 0;\n        }\n        elsif ($line =~ /^-----END PLAGE SIGNATURE-----\\s*\\z/) {\n            last;\n        }\n        elsif ($collect_msg) {\n            $msg .= ($line =~ s/^ //r);\n        }\n        elsif ($collect_sig) {\n            $base64_sig .= $line;\n        }\n    }\n\n    my $json_data = decode_base64($base64_sig);\n\n    my $sha256     = substr($json_data, 0, HASH_SIZE,      '');\n    my $sha256_sig = substr($json_data, 0, SIGNATURE_SIZE, '');\n\n    if ($sha256 eq '' or $sha256_sig eq '') {\n        die \"No signature found!\\n\";\n    }\n\n    if (sha256($json_data) ne $sha256) {\n        die \"The signature has been modified: the SHA256 hash does not match!\\n\";\n    }\n\n    my $info       = eval { decode_json($json_data) } // die \"Invalid JSON data!\\n\";\n    my $sig        = decode_base64($info->{sig});\n    my $ed_pub     = $info->{ed_pub};\n    my $x_pub      = $info->{x_pub};\n    my $ed_pub_key = ed25519_from_public($ed_pub);\n    my $user_info  = get_user_info_for_ed25519_public($ed_pub);\n\n    if (not verify_signature($sha256, $sha256_sig, $ed_pub_key)) {\n        die \"The signature has been modified: invalid signature for the SHA256 hash!\\n\";\n    }\n\n    if (not verify_signature($msg, $sig, $ed_pub_key)) {\n        die \"Bad signature: the message has been modified!\\n\";\n    }\n\n    $callback->($msg);\n\n    if (defined $user_info) {\n\n        if ($user_info->{x_pub} ne $x_pub) {\n            die \"The public X25519 key does not match!\\n\";\n        }\n\n        if (export_key($info->{x_pub}, $ed_pub) ne $user_info->{public_key}) {\n            die \"Public key does not match!\\n\";\n        }\n\n        warn \"Signature from $user_info->{username}\\n\";\n    }\n    else {\n        warn \"Public key: \" . export_key($info->{x_pub}, $ed_pub) . \"\\n\";\n        warn \"WARNING: Could not find the key in our keyring!\\n\";\n    }\n\n    warn \"Created on: \" . scalar localtime($info->{time}) . \"\\n\";\n    warn \"\\nGood signature!\\n\\n\";\n    return $user_info;\n}\n\nsub create_armor ($enc, $ed_key) {\n\n    my $armor = \"-----BEGIN PLAGE ENCRYPTED DATA-----\\n\";\n\n    my %info       = %$enc;\n    my $ciphertext = delete $info{ciphertext};\n    my $json       = encode_json(\\%info);\n    my $length     = length($json);\n    my $content    = sprintf(\"%*d%s%s\", JSON_LENGTH_WIDTH, $length, $json, $ciphertext);\n    my $sha256     = sha256($content);\n    my $signature  = sign_message($sha256, $ed_key);\n\n    $armor .= encode_base64($sha256 . $signature . $content);\n    $armor .= \"-----END PLAGE ENCRYPTED DATA-----\\n\";\n\n    return $armor;\n}\n\nsub decode_armor ($armor) {\n\n    my $collect     = 0;\n    my $base64_data = '';\n\n    open my $fh, '<:raw', \\$armor;\n    while (defined(my $line = <$fh>)) {\n        if ($line =~ /^-----BEGIN PLAGE ENCRYPTED DATA-----\\s*\\z/) {\n            $collect = 1;\n        }\n        elsif ($line =~ /^-----END PLAGE ENCRYPTED DATA-----\\s*\\z/) {\n            last;\n        }\n        elsif ($collect) {\n            $base64_data .= $line;\n        }\n    }\n\n    my $content    = decode_base64($base64_data);\n    my $sha256     = substr($content, 0, HASH_SIZE,      '');\n    my $sha256_sig = substr($content, 0, SIGNATURE_SIZE, '');\n\n    if ($sha256 eq '' or $sha256_sig eq '') {\n        die \"Invalid armor!\\n\";\n    }\n\n    if (sha256($content) ne $sha256) {\n        die \"The message has been modified: the SHA256 hash does not match!\\n\";\n    }\n\n    my $length = substr($content, 0, JSON_LENGTH_WIDTH, '');\n\n    if ($length =~ /^\\s*([0-9]+)\\z/) {\n        $length = 0 + $1;\n    }\n\n    if (!$length or $length <= 0) {\n        die \"Invalid armor!\\n\";\n    }\n\n    my $json = substr($content, 0, $length, '');\n    my $info = decode_json($json) // die \"Invalid JSON data!\\n\";\n\n    if (not verify_signature($sha256, $sha256_sig, ed25519_from_public($info->{ed_pub}))) {\n        die \"Invalid armor: the signature of the SHA256 hash does not match!\\n\";\n    }\n\n    $info->{ciphertext} = $content;\n    return $info;\n}\n\nsub export_key ($x_public_key, $ed_public_key) {\n    require Math::BigInt;\n\n    my $x  = Math::BigInt->from_hex($x_public_key)->to_base(EXPORT_KEY_BASE);\n    my $ed = Math::BigInt->from_hex($ed_public_key)->to_base(EXPORT_KEY_BASE);\n\n    join('-', $x, $ed);\n}\n\nsub decode_exported_key ($public_key) {\n    require Math::BigInt;\n\n    my ($x, $ed) = split(/\\s*-\\s*/, $public_key, 2);\n\n    $x  // return;\n    $ed // return;\n\n#<<<\n    (\n        Math::BigInt->from_base($x, EXPORT_KEY_BASE)->to_hex,\n        Math::BigInt->from_base($ed, EXPORT_KEY_BASE)->to_hex\n    );\n#>>>\n}\n\nsub read_password ($text) {\n\n    ReadMode('noecho');\n    my $passphrase = $term->readline($text);\n    ReadMode('restore');\n    warn \"\\n\";\n\n    return $passphrase;\n}\n\nsub create_cipher_password ($passphrase, $x_public_key, $ed_public_key) {\n#<<<\n    unpack(\"H*\",\n        sha256(\n            sha256(pack(\"H*\", $x_public_key)) .\n            sha256($passphrase) .\n            sha256(pack(\"H*\", $ed_public_key))\n        )\n    );\n#>>>\n}\n\nsub decrypt_private_keys ($info, $prompt = 'Passphrase: ') {\n\n    my $x_pub   = $info->{x_pub};\n    my $x_priv  = $info->{x_priv};\n    my $ed_pub  = $info->{ed_pub};\n    my $ed_priv = $info->{ed_priv};\n\n    for (1 .. 10) {\n\n        my $passphrase = '';\n\n        if ($info->{has_password}) {\n            $passphrase = read_password($prompt) // last;\n        }\n\n        my $pass   = create_cipher_password($passphrase, $x_pub, $ed_pub);\n        my $cipher = create_cipher($pass, PASSPHRASE_CIPHER, PASSPHRASE_CHAINING_MODE);\n\n        my $x_raw = $cipher->decrypt($x_priv);\n        my $x_key = eval { x25519_from_private_raw($x_raw) } // next;\n\n        if ($x_key->key2hash->{pub} ne $x_pub) {\n            next;\n        }\n\n        my $ed_raw = $cipher->decrypt($ed_priv);\n        my $ed_key = eval { ed25519_from_private_raw($ed_raw) } // next;\n\n        if ($ed_key->key2hash->{pub} ne $ed_pub) {\n            next;\n        }\n\n        return ($x_key, $ed_key);\n    }\n\n    return (undef, undef);\n}\n\nsub import_key ($public_key) {\n    my ($x_pub, $ed_pub) = decode_exported_key($public_key);\n\n    if (   not defined($x_pub)\n        or not defined($ed_pub)\n        or length($x_pub) != PK_HEX_SIZE\n        or length($ed_pub) != PK_HEX_SIZE) {\n        die \"Invalid public key!\\n\";\n    }\n\n    if (exists $KEYRING{keys}{X25519}{$x_pub}) {\n        die \"The X25519 key already exists for username: $KEYRING{keys}{X25519}{$x_pub}{username}\\n\";\n    }\n\n    if (exists $KEYRING{keys}{Ed25519}{$ed_pub}) {\n        die \"The Ed25519 key already exists for username:  $KEYRING{keys}{Ed25519}{$ed_pub}{username}\\n\";\n    }\n\n    # Make sure the keys work\n    my $x_key  = x25519_from_public($x_pub);\n    my $ed_key = ed25519_from_public($ed_pub);\n\n    if ($x_key->key2hash->{pub} ne $x_pub) {\n        die \"Invalid X25519 key!\\n\";\n    }\n\n    if ($ed_key->key2hash->{pub} ne $ed_pub) {\n        die \"Invalid Ed25519 key!\\n\";\n    }\n\n    my $username = $CONFIG{name} // $term->readline('Username: ') // return;\n\n    $username = make_unique_username($username, $x_pub);\n\n    my %info = (\n        time     => time,\n        username => $username,\n\n        x_pub  => $x_pub,\n        ed_pub => $ed_pub,\n\n        public_key => export_key($x_pub, $ed_pub),\n               );\n\n    $KEYRING{keys}{X25519}{$x_pub}   = \\%info;\n    $KEYRING{keys}{Ed25519}{$ed_pub} = \\%info;\n\n    if (store(\\%KEYRING, $keyring_file)) {\n        say \"Successfully imported key: $username\";\n    }\n    else {\n        die \"Failed to import key: $!\\n\";\n    }\n\n    return 1;\n}\n\nsub remove_key ($username) {\n    my @keys = find_keys($username);\n\n    if (not @keys) {\n        die \"No keys found matching the given username.\\n\";\n    }\n\n    my $removed = 0;\n\n    foreach my $key (@keys) {\n        say \"Public key : $key->{public_key}\";\n        say \"Added on   : \" . localtime($key->{time});\n        if ($term->ask_yn(prompt => \"Remove key $key->{username}?\", default => 'n')) {\n            if ($key->{mine} ? $term->ask_yn(prompt => \"Are you sure?\", default => 'n') : 1) {\n                delete $KEYRING{keys}{X25519}{$key->{x_pub}};\n                delete $KEYRING{keys}{Ed25519}{$key->{ed_pub}};\n                ++$removed;\n            }\n        }\n    }\n\n    if ($removed and store(\\%KEYRING, $keyring_file)) {\n        say \"Successfully removed $removed keys.\";\n    }\n    else {\n        say \"No keys removed.\";\n    }\n\n    return 1;\n}\n\nsub change_password ($username) {\n    my @keys = grep { $_->{mine} } find_keys($username);\n\n    if (not @keys) {\n        die \"No owned keys found matching the given username.\\n\";\n    }\n\n    my $updated = 0;\n\n    foreach my $key (@keys) {\n        if ($term->ask_yn(prompt => \"Change password for $key->{username}?\", default => 'n')) {\n\n            my ($x_key, $ed_key) = decrypt_private_keys($key, \"Old passphrase: \");\n            my $passphrase = read_confirmed_passphrase(\"New passphrase: \");\n\n            if (not defined($passphrase) or $passphrase eq '') {\n                if ($term->ask_yn(prompt => \"Are you sure you want to use no password?\", default => 'n')) {\n                    $passphrase = '';\n                }\n                else {\n                    next;\n                }\n            }\n\n            my $x_key_hash  = $x_key->key2hash;\n            my $ed_key_hash = $ed_key->key2hash;\n\n            my $x_public_key  = $x_key_hash->{pub};\n            my $ed_public_key = $ed_key_hash->{pub};\n\n            my ($x_private_key, $ed_private_key) = encrypt_private_keys($passphrase, $x_key_hash, $ed_key_hash);\n\n            if ($passphrase eq '') {\n                $key->{has_password} = 0;\n            }\n            else {\n                $key->{has_password} = 1;\n            }\n\n            $key->{x_priv}  = $x_private_key;\n            $key->{ed_priv} = $ed_private_key;\n\n            $KEYRING{keys}{X25519}{$x_public_key}   = $key;\n            $KEYRING{keys}{Ed25519}{$ed_public_key} = $key;\n\n            ++$updated;\n        }\n    }\n\n    if ($updated and store(\\%KEYRING, $keyring_file)) {\n        say \"Successfully changed the password of $updated keys.\";\n    }\n    else {\n        say \"No passwords changed.\";\n    }\n\n    return 1;\n}\n\nsub make_unique_username ($username, $x_public_key) {\n\n    $username = join('_', split(' ', $username));\n\n    if ($username ne '') {\n        $username .= '-';\n    }\n\n    $username .= substr($x_public_key, -(USER_ID_SIZE));\n\n    return $username;\n}\n\nsub read_confirmed_passphrase ($prompt = 'Passprhase: ') {\n    my $passphrase = read_password($prompt) // return;\n\n    while (1) {\n\n        my $confirmed_passphrase = read_password('Confirm passphrase: ') // return;\n\n        if ($passphrase eq $confirmed_passphrase) {\n            last;\n        }\n\n        say \"Passphrases do not match. Try again.\";\n        $passphrase = read_password($prompt) // return;\n    }\n\n    return $passphrase;\n}\n\nsub encrypt_private_keys ($passphrase, $x_key, $ed_key) {\n\n    my $cipher_password = create_cipher_password($passphrase, $x_key->{pub}, $ed_key->{pub});\n    my $cipher          = create_cipher($cipher_password, PASSPHRASE_CIPHER, PASSPHRASE_CHAINING_MODE);\n\n    my $x_private_key  = $cipher->encrypt(pack(\"H*\", $x_key->{priv}));\n    my $ed_private_key = $cipher->encrypt(pack(\"H*\", $ed_key->{priv}));\n\n    return ($x_private_key, $ed_private_key);\n}\n\nsub generate_new_key {\n\n    my $username   = $term->readline('Username: ') // return;\n    my $passphrase = read_confirmed_passphrase()   // return;\n\n    my $default = $term->ask_yn(prompt => \"Make this the default key?\", default => 'y');\n\n    my $x25519_key  = x25519_random_key();\n    my $ed25519_key = ed25519_random_key();\n\n    my $x_key  = $x25519_key->key2hash;\n    my $ed_key = $ed25519_key->key2hash;\n\n    my $x_public_key  = $x_key->{pub};\n    my $ed_public_key = $ed_key->{pub};\n\n    $username = make_unique_username($username, $x_public_key);\n\n    my ($x_private_key, $ed_private_key) = encrypt_private_keys($passphrase, $x_key, $ed_key);\n\n    my %info = (\n        time => time,\n        mine => 1,\n\n        username     => $username,\n        has_password => (($passphrase eq '') ? 0 : 1),\n\n        x_pub  => $x_public_key,\n        x_priv => $x_private_key,\n\n        ed_pub  => $ed_public_key,\n        ed_priv => $ed_private_key,\n\n        public_key => export_key($x_public_key, $ed_public_key),\n               );\n\n    $KEYRING{keys}{X25519}{$x_public_key}   = \\%info;\n    $KEYRING{keys}{Ed25519}{$ed_public_key} = \\%info;\n\n    if ($default) {\n        $KEYRING{keys}{default} = $x_public_key;\n    }\n\n    store(\\%KEYRING, $keyring_file);\n\n    say \"Successfully generated key: $username\";\n    return 1;\n}\n\nsub get_all_keys {\n    my $xkeys = $KEYRING{keys}{X25519};\n    my @keys  = map { $_->[1] } sort { $a->[0] cmp $b->[0] } map { [CORE::fc($_->{username}), $_] } values %$xkeys;\n    return @keys;\n}\n\nsub list_my_keys {\n\n    my @my_keys = grep { $_->{mine} } get_all_keys();\n\n    foreach my $key (@my_keys) {\n        say \"Username     : \", $key->{username};\n        say \"Public key   : \", $key->{public_key};\n        say \"Created on   : \", scalar localtime($key->{time});\n        say \"Has password : \", ($key->{has_password}                       ? 'Yes' : 'No');\n        say \"Default key  : \", (($KEYRING{keys}{default} eq $key->{x_pub}) ? \"Yes\" : \"No\");\n        say '';\n    }\n\n    return 1;\n}\n\nsub list_keys {\n\n    my @keys = get_all_keys();\n\n    foreach my $key (@keys) {\n        say \"Username   : \", $key->{username};\n        say \"Public key : \", $key->{public_key};\n        say \"Added on   : \", scalar localtime($key->{time});\n        say '';\n    }\n\n    return 1;\n}\n\nsub select_one_key ($keys) {\n\n    if (scalar(@$keys) == 1) {\n        return $keys->[0];\n    }\n\n    if (scalar(@$keys) > 1) {\n        die \"Multiple usernames matched:\\n\\t\" . join(\"\\n\\t\", map { $_->{username} } @$keys) . \"\\n\";\n    }\n\n    die \"No username could be matched.\\n\";\n}\n\nsub find_keys ($username) {\n\n    my @keys  = get_all_keys();\n    my $regex = qr/\\Q$username\\E/i;\n\n    my @found_keys;\n    foreach my $key (@keys) {\n        if ($key->{username} =~ $regex) {\n            push @found_keys, $key;\n        }\n    }\n\n    return @found_keys;\n}\n\nsub get_public_x25519_for_user ($username) {\n    my @keys = find_keys($username);\n    my $key  = select_one_key(\\@keys);\n    return x25519_from_public($key->{x_pub});\n}\n\nsub get_info_for_public_x25519 ($x_pub) {\n    $KEYRING{keys}{X25519}{$x_pub};\n}\n\nsub get_private_keys_for_public_x25519 ($x_pub) {\n    my $info = get_info_for_public_x25519($x_pub);\n    ref($info) eq 'HASH' or die \"No decryption key found!\\n\";\n    $info->{mine} || die \"Sorry! You don't have the private key of $info->{username}!\\n\";\n    decrypt_private_keys($info);\n}\n\nsub change_user ($username) {\n    my @keys = grep { $_->{mine} } find_keys($username);\n    my $key  = select_one_key(\\@keys);\n    $KEYRING{keys}{default} = $key->{x_pub};\n    warn \"Current user: $key->{username}\\n\";\n    return 1;\n}\n\nsub get_input_fh {\n    my $fh = \\*STDIN;\n\n    if (@ARGV and -t $fh) {\n        sysopen(my $file_fh, $ARGV[0], 0)\n          or die \"Can't open file <<$ARGV[0]>> for reading: $!\";\n        return $file_fh;\n    }\n\n    return $fh;\n}\n\nsub read_input {\n    my $fh = get_input_fh();\n    local $/;\n    <$fh>;\n}\n\nsub help ($exit_code) {\n\n    local $\" = \" \";\n\n    my @compression_methods = grep {\n        eval { uncompress_data($COMPRESSION_METHODS{$_}('test')) eq 'test' }\n    } sort keys %COMPRESSION_METHODS;\n\n    my @chaining_modes = map { uc } qw(cbc pcbc cfb ofb ctr);\n\n    my @valid_ciphers = sort grep {\n        eval { require \"Crypt/Cipher/$_.pm\"; 1 };\n      } qw(\n      AES Anubis Twofish Camellia Serpent SAFERP\n      );\n\n    print <<\"EOT\";\nusage: $0 [options] [<input] [>output]\n\nEncryption and signing:\n\n    -e --encrypt=user   : Encrypt data for a given user\n    -d --decrypt        : Decrypt data encrypted for you\n    -s --sign!          : Sign the message with your private key (default: $CONFIG{sign})\n       --clear-sign     : Create a signed message, without encryption\n       --verify-message : Verify a clear signed message\n       --cipher=s       : Change the symmetric cipher (default: $CONFIG{cipher})\n                          valid: @valid_ciphers\n       --chain-mode=s   : Change the chaining mode (default: $CONFIG{chain_mode})\n                          valid: @chaining_modes\n\nUsers:\n\n    --user=name         : Change the default user temporarily\n    --default-user=name : Set a new default user\n\nKeys:\n\n    -l --list-keys      : List all the keys\n    -L --list-mine      : List the keys that you own\n    -g --generate-key   : Generate a new key-pair\n    -i --import=key     : Import a given public key\n       --name=s         : Give a name to the imported key\n       --export=name    : Export a public key from your keyring\n       --remove=name    : Remove a given key from your keyring\n       --password=name  : Change the passphrase of your key\n\nCompression options:\n\n    --compress!         : Compress data before encryption (default: $CONFIG{compress})\n    --compress-method=s : Compression method (default: $CONFIG{compress_method})\n                          valid: @compression_methods\n\nExamples:\n\n    # Generate a key\n    $0 -g\n\n    # Import a key\n    $0 -i [PublicKey] --name=Alice\n\n    # Encrypt and sign a message for Alice\n    $0 -e=Alice -s message.txt > message.enc\n\n    # Decrypt a received message\n    $0 -d message.enc > message.txt\nEOT\n\n    exit($exit_code);\n}\n\nsub version {\n\n    my $width = 20;\n\n    printf(\"%-*s %s\\n\", $width, SHORT_APPNAME,        VERSION);\n    printf(\"%-*s %s\\n\", $width, 'Crypt::CBC',         $Crypt::CBC::VERSION);\n    printf(\"%-*s %s\\n\", $width, 'Crypt::PK::X25519',  $Crypt::PK::X25519::VERSION);\n    printf(\"%-*s %s\\n\", $width, 'Crypt::PK::Ed25519', $Crypt::PK::Ed25519::VERSION);\n\n    exit(0);\n}\n\nGetOptions(\n           'cipher=s'          => \\$CONFIG{cipher},\n           'chain-mode|mode=s' => \\$CONFIG{chain_mode},\n           'compress!'         => \\$CONFIG{compress},\n           'compress-method=s' => \\$CONFIG{compress_method},\n           'name=s'            => \\$CONFIG{name},\n           'user=s'            => \\$CONFIG{change_user},\n           'default-user=s'    => \\$CONFIG{change_default_user},\n           'password:s'        => \\$CONFIG{change_password},\n           'a|armor'           => \\$CONFIG{armor},\n           'l|list-keys'       => \\$CONFIG{list_keys},\n           'L|list-mine'       => \\$CONFIG{list_my_keys},\n           'i|import-key=s'    => \\$CONFIG{import},\n           'export-key:s'      => \\$CONFIG{export},\n           'remove-key:s'      => \\$CONFIG{remove},\n           'g|generate-key!'   => \\$CONFIG{generate_key},\n           'e|encrypt=s'       => \\$CONFIG{encrypt},\n           'd|decrypt!'        => \\$CONFIG{decrypt},\n           's|sign!'           => \\$CONFIG{sign},\n           'clear-sign'        => \\$CONFIG{clear_sign},\n           'verify-message'    => \\$CONFIG{verify_message},\n           'v|version'         => \\&version,\n           'h|help'            => sub { help(0) },\n          )\n  or die(\"Error in command line arguments\\n\");\n\nif (not exists $COMPRESSION_METHODS{$CONFIG{compress_method}}) {\n    die \"Invalid compression method: $CONFIG{compress_method}\\n\";\n}\n\nif (defined $CONFIG{change_user}) {\n    change_user($CONFIG{change_user});\n}\n\nif (defined $CONFIG{change_default_user}) {\n    change_user($CONFIG{change_default_user});\n    store(\\%KEYRING, $keyring_file);\n}\n\nif ($CONFIG{generate_key}) {\n    generate_new_key();\n    exit 0;\n}\n\nif ($CONFIG{list_keys}) {\n    list_keys();\n    exit 0;\n}\n\nif ($CONFIG{list_my_keys}) {\n    list_my_keys();\n    exit 0;\n}\n\nif (defined($CONFIG{export})) {\n    foreach my $key (find_keys($CONFIG{export})) {\n        say \"Username   : $key->{username}\";\n        say \"Public key : $key->{public_key}\";\n        say '';\n    }\n    exit 0;\n}\n\nif (defined($CONFIG{import})) {\n    import_key($CONFIG{import});\n    exit 0;\n}\n\nif (defined($CONFIG{remove})) {\n    remove_key($CONFIG{remove});\n    exit 0;\n}\n\nif (defined($CONFIG{change_password})) {\n    change_password($CONFIG{change_password});\n    exit 0;\n}\n\nmy $local_user = sub {\n\n    if (not defined($KEYRING{keys}{default}) or not defined($KEYRING{keys}{X25519}{$KEYRING{keys}{default}})) {\n        die \"No default user found!\\nPass --user=s to select a key, or generate a new key with -g\\n\";\n    }\n\n    state $x_key;\n    state $ed_key;\n\n    if (defined($x_key) and defined($ed_key)) {\n        return ($x_key, $ed_key);\n    }\n\n    ($x_key, $ed_key) = decrypt_private_keys($KEYRING{keys}{X25519}{$KEYRING{keys}{default}});\n\n    return ($x_key, $ed_key);\n};\n\nif ($CONFIG{clear_sign}) {\n    my $text = read_input();\n    my ($x_key, $ed_key) = $local_user->();\n    print create_clear_signed_message($text, $ed_key);\n    exit 0;\n}\n\nif ($CONFIG{verify_message}) {\n    my $text = read_input();\n    verify_clear_signed_message($text);\n    exit 0;\n}\n\nif (defined($CONFIG{encrypt})) {\n\n    my $x_pub = get_public_x25519_for_user($CONFIG{encrypt});\n\n    my $text   = read_input();\n    my $enc    = encrypt($text, $x_pub);\n    my $ed_key = undef;\n\n    if ($CONFIG{sign}) {\n        (undef, $ed_key) = $local_user->();\n    }\n    else {\n        $ed_key = ed25519_random_key();\n    }\n\n    $enc->{ed_pub}    = $ed_key->key2hash->{pub};\n    $enc->{signature} = encode_base64(sign_message($text, $ed_key));\n\n    my $armor = create_armor($enc, $ed_key);\n\n    if ($CONFIG{sign}) {\n        syswrite(STDOUT, create_clear_signed_message($armor, $ed_key));\n    }\n    else {\n        syswrite(STDOUT, $armor);\n    }\n\n    exit 0;\n}\n\nif ($CONFIG{decrypt}) {\n    my $armor      = read_input();\n    my $exped_info = undef;\n\n    if ($armor =~ /^-----BEGIN PLAGE SIGNED MESSAGE-----\\s*$/m) {\n        $exped_info = verify_clear_signed_message($armor, sub ($msg) { $armor = $msg });\n    }\n\n    my $enc = decode_armor($armor);\n\n    if (defined($exped_info) and $enc->{ed_pub} ne $exped_info->{ed_pub}) {\n        die \"The expeditor public signature key does not match!\\n\";\n    }\n\n    my $dest_info = get_info_for_public_x25519($enc->{dest});\n\n    if (not defined $dest_info) {\n        die \"Sorry! You don't have the private key to decrypt this message!\\n\";\n    }\n\n    warn \"Destination  : \" . $dest_info->{username} . \"\\n\";\n    warn \"Cipher used  : \" . join('+', uc($enc->{chain_mode}), $enc->{cipher}) . \"\\n\";\n    warn \"Compressed   : \" . ($enc->{compressed} ? \"Yes\" : \"No\") . \"\\n\";\n    warn \"Encrypted on : \" . localtime($enc->{time}) . \"\\n\";\n\n    my ($x_priv, undef) = get_private_keys_for_public_x25519($enc->{dest});\n\n    my $data = decrypt($enc, $x_priv);\n\n    if (not verify_signature($data, decode_base64($enc->{signature}), ed25519_from_public($enc->{ed_pub}))) {\n        die \"The signature of the message does not match!\\n\";\n    }\n\n    syswrite(STDOUT, $data);\n    exit 0;\n}\n\nhelp(1);\n"
  },
  {
    "path": "Encryption/simple_XOR_cipher.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 03 March 2022\n# https://github.com/trizen\n\n# A simple encryption cihpher, using XOR with SHA-512 of the key and substring shuffling.\n\n# WARNING: should NOT be used for encrypting real-world data.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Block_cipher\n#   https://en.wikipedia.org/wiki/XOR_cipher\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory      qw(random_bytes);\nuse Digest::SHA  qw(sha512);\n\nuse constant {\n              ROUNDS => 13,    # how many encryption rounds to perform\n             };\n\nsub encrypt ($str, $key) {\n\n    if (length($str) > 64) {\n        die \"Input string is too long. Max size: 64\\n\";\n    }\n\n    if (length($str) != 64) {\n        $str .= random_bytes(64 - length($str));\n    }\n\n    $key = sha512($key);\n    $str ^= $key;\n\n    my $i = my $l = length($str);\n\n    for my $k (1 .. ROUNDS) {\n        $str =~ s/(.{$i})(.)/$2$1/sg while (--$i > 0);\n        $str ^= sha512($key . $k);\n        $str =~ s/(.{$i})(.)/$2$1/sg while (++$i < $l);\n        $str ^= sha512($k . $key);\n    }\n\n    return $str;\n}\n\nsub decrypt ($str, $key, $len = 64) {\n\n    $key = sha512($key);\n\n    my $i = my $l = length($str);\n\n    for my $k (reverse(1 .. ROUNDS)) {\n        $str ^= sha512($k . $key);\n        $str =~ s/(.)(.{$i})/$2$1/sg while (--$i > 0);\n        $str ^= sha512($key . $k);\n        $str =~ s/(.)(.{$i})/$2$1/sg while (++$i < $l);\n    }\n\n    $str ^= $key;\n    $str = substr($str, 0, $len);\n    return $str;\n}\n\nmy $text = \"Hello, world!\";\nmy $key  = \"foo\";\n\nsay decrypt(encrypt($text, $key), $key, length($text));    #=> \"Hello, world!\"\n"
  },
  {
    "path": "File Readers/ldump",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 26 February 2013\n# https://github.com/trizen\n\n# Get the specified lines from a given file.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\n@ARGV == 2 or die <<\"USAGE\";\nusage: ldump [file] [lines]\n\nexample: ldump /tmp/file.txt 23-40,80,105\nUSAGE\n\nmy @lines = map { /^(\\d+)(?>-|\\.\\.)(\\d+)\\z/ ? ($1 .. $2) : $_ }\n  split /\\s*,\\s*/, pop;\n\nmy %lookup;\n@lookup{@lines} = ();\n\nwhile (<>) {\n    print if exists($lookup{$.});\n}\n"
  },
  {
    "path": "File Readers/multi-file-line-reader.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 13 April 2012\n# https://github.com/trizen\n\n# If you saw this code on perlmonks.org,\n# posted by an Anonymous Monk, that was me.\n\nmy (@files) = @ARGV ? @ARGV : ($0, $0);\n\nmy @fh;\nmy $i = 0;\n\nforeach my $file (@files) {\n    next unless -f -r $file;\n    open $fh[$i++], '<', $file\n      or die \"Cannot open ${file}: $!\";\n}\n\nwhile (1) {\n    my @lines;\n\n    foreach my $i (0 .. $#fh) {\n\n        next unless ref $fh[$i] eq 'GLOB';\n        push @lines, scalar readline $fh[$i];\n\n        if (eof $fh[$i]) {\n            close $fh[$i];\n            $fh[$i] = undef;\n        }\n    }\n\n    last unless @lines;\n\n    foreach my $line (@lines) {\n        print $line;\n    }\n}\n"
  },
  {
    "path": "File Readers/n_repeated_lines.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 25 April 2014\n# Website: https://github.com/trizen\n\n# Print only the lines that repeat n times in one or more files.\n# usage: perl n_repeated_lines.pl [n] [file1.txt] [...]\n\nuse strict;\nuse warnings;\n\nmy $n = @ARGV && not(-f $ARGV[0]) ? shift() : 2;\n\nmy %seen;\nwhile (<>) {\n    /\\S/ || next;\n    ++$seen{unpack('A*')} == $n && print;\n}\n"
  },
  {
    "path": "File Readers/tailz",
    "content": "#!/usr/bin/perl\n\n# Simple program to read the last n line(s) of a file.\n# Reads from the end of the file for efficiency.\n\n# Originally coded by zentara on 06 September 2002:\n#   https://www.perlmonks.org/index.pl?node_id=195768\n\n# Improved by Trizen on 11 February 2012\n\n# usage tailz  filename  numberoflines\n\nmy $filename = shift or die \"usage: $0 file numlines\\n\";\nmy $numlines = shift // 10;\nmy $byte;\n\n# Open the file in read mode\nopen my $fh, '<', $filename or die \"Couldn't open $filename: $!\";\n\n# Rewind from the end of the file until count of eol 's\nseek $fh, -1, 2;    # get past last eol\nmy $count = 0;\n\nwhile (tell($fh) > 0) {\n    seek $fh, -1, 1;\n    read $fh, $byte, 1;\n    last if $byte eq \"\\n\" and ++$count == $numlines;\n    seek $fh, -1, 1;\n}\n\nlocal $/ = undef;\nprint scalar <$fh>;\n"
  },
  {
    "path": "File Workers/arxiv_pdf_renamer.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 13 February 2024\n# https://github.com/trizen\n\n# Rename PDFs downloaded from arxiv.org, to their paper title.\n\n# usage: perl script.pl [PDF files]\n\nuse 5.036;\nuse WWW::Mechanize;\nuse File::Basename        qw(dirname basename);\nuse File::Spec::Functions qw(catfile);\n\nmy $mech = WWW::Mechanize->new(\n                               autocheck     => 0,\n                               show_progress => 0,\n                               stack_depth   => 10,\n                               agent         => 'Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:122.0) Gecko/20100101 Firefox/122.0',\n                              );\n\nforeach my $pdf_file (@ARGV) {\n\n    my $pdf_content = do {\n        open my $fh, '<:raw', $pdf_file\n          or do {\n            warn \"Can't open file <<$pdf_file>>: $!\\n\";\n            next;\n          };\n        local $/;\n        <$fh>;\n    };\n\n    my $url = undef;\n\n    if ($pdf_content =~ m{\\bURI\\s*\\((https?://arxiv\\.org/.*?)\\)}) {\n        $url = $1;\n        $url =~ s{^http://}{https://};\n    }\n    elsif (basename($pdf_file) =~ /^([0-9]+\\.[0-9]+)\\.pdf\\z/i) {\n        $url = \"https://arxiv.org/abs/$1\";\n    }\n\n    my $title = undef;\n\n    if (defined($url)) {\n        my $resp = $mech->get($url);\n\n        if ($resp->is_success) {\n            $title = $resp->title;\n        }\n    }\n\n    if (defined($title)) {\n\n        $title =~ s{\\[.*?\\]\\s*}{};\n        $title =~ s/: / - /g;\n        $title =~ tr{:\"*/?\\\\|}{;'+%!%%};    # \"\n        $title =~ tr/<>${}//d;\n\n        $title = join(q{ }, split(q{ }, $title));\n        $title = substr($title, 0, 250);            # make sure the filename is not too long\n\n        $title .= \".pdf\";\n\n        my $basename = basename($pdf_file);\n        say \"Renaming: $basename -> $title\";\n\n        my $dest = catfile(dirname($pdf_file), $title);\n\n        if (-e $dest) {\n            warn \"File <<$dest>> already exists... Skipping...\\n\";\n        }\n        else {\n            rename($pdf_file, $dest) or warn \"Failed to rename: $!\\n\";\n        }\n    }\n    else {\n        say \"Not an arxiv PDF: $pdf_file\";\n    }\n}\n\n__END__\n\n# Example:\n\n$ perl arxiv_pdf_renamer.pl *.pdf\n** GET https://arxiv.org/abs/math/0504119v1 ==> 200 OK (1s)\nRenaming: 0504119.pdf -> The Carmichael numbers up to 10^17.pdf\n** GET https://arxiv.org/abs/2311.07048v1 ==> 200 OK\nRenaming: 2311.07048.pdf -> Gauss-Euler Primality Test.pdf\n"
  },
  {
    "path": "File Workers/auto_extensions.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 30 May 2020\n# https://github.com/trizen\n\n# Automatically determine the mime type of files and add the corresponding file extensions.\n\n# Usage:\n#   perl script.pl [dir]\n\nuse 5.020;\nuse autodie;\nuse warnings;\n\nuse List::Util qw(any);\nuse File::Find qw(find);\nuse File::MimeInfo::Magic qw(mimetype extensions);\nuse File::Basename qw(dirname basename);\nuse File::Spec::Functions qw(curdir catfile);\n\nmy $dir = $ARGV[0] // curdir();\n\nfind(\n    {\n     no_chdir => 1,\n     wanted   => sub {\n\n         return 1 if not -f $_;\n\n         my $dirname    = dirname($_);\n         my $basename   = basename($_);\n         my @extensions = extensions(mimetype($_));\n\n         return 1 if not @extensions;\n\n         if (any { defined($_) and $basename =~ /\\.\\Q$_\\E\\z/ } @extensions) {\n             return 1;    # already has extension -- skip\n         }\n\n         my $ext     = $extensions[0] // return 1;\n         my $newfile = catfile($dirname, $basename . '.' . $ext);\n\n         if (-e $newfile) {\n             say \":: $newfile already exists...\";\n         }\n         else {\n             say \":: Renaming: $_ -> $newfile\";\n             rename($_, $newfile);\n         }\n     },\n    } => $dir\n);\n"
  },
  {
    "path": "File Workers/collect_gifs.pl",
    "content": "#!/usr/bin/perl\n\n# Collect and move GIF images into a specific directory, by scanning a given a directory (and its subdirectories) for GIF images.\n\nuse 5.036;\nuse File::Find            qw(find);\nuse File::Copy            qw(move);\nuse File::Path            qw(make_path);\nuse File::Basename        qw(basename);\nuse File::Spec::Functions qw(catfile curdir rel2abs);\nuse Getopt::Long          qw(GetOptions);\n\nmy $use_exiftool = 0;    # true to use `exiftool` instead of `File::MimeInfo::Magic`\n\nsub is_gif ($file) {\n\n    if ($use_exiftool) {\n        my $res = `exiftool \\Q$file\\E`;\n\n        $? == 0       or return;\n        defined($res) or return;\n\n        return ($res =~ m{^MIME\\s+Type\\s*:\\s*image/gif}mi);\n    }\n\n    require File::MimeInfo::Magic;\n    (File::MimeInfo::Magic::magic($file) // '') eq 'image/gif';\n}\n\nsub collect_gif ($file, $directory) {\n\n    my $dest = catfile($directory, basename($file));\n\n    if (-e $dest) {\n        warn \"File <<$dest>> already exists...\\n\";\n        return;\n    }\n\n    move($file, $dest);\n}\n\nGetOptions('exiftool!' => \\$use_exiftool,)\n  or die \"Error in command-line arguments!\";\n\nmy @dirs = @ARGV;\n\n@dirs || die \"usage: perl $0 [directory | files]\\n\";\n\nmy $directory = rel2abs(\"GIF images\");    # directory where to move the files\n\nif (not -d $directory) {\n    make_path($directory)\n      or die \"Can't create directory <<$directory>>: $!\";\n}\n\nif (not -d $directory) {\n    die \"<<$directory>> is not a directory!\";\n}\n\nfind(\n    {\n     wanted => sub {\n         if (-f $_ and is_gif($_)) {\n             say \":: Moving file: $_\";\n             collect_gif($_, $directory);\n         }\n     },\n    },\n    @dirs\n);\n"
  },
  {
    "path": "File Workers/collect_videos.pl",
    "content": "#!/usr/bin/perl\n\n# Collect and move video files into a specific directory, by scanning a given a directory (and its subdirectories) for video files.\n\n# Requires `exiftool`.\n\nuse 5.036;\nuse File::Find            qw(find);\nuse File::Copy            qw(move);\nuse File::Path            qw(make_path);\nuse File::Basename        qw(basename);\nuse File::Spec::Functions qw(catfile curdir rel2abs);\n\nsub is_video ($file) {\n    my $res = `exiftool \\Q$file\\E`;\n\n    $? == 0       or return;\n    defined($res) or return;\n\n    $res =~ m{^MIME\\s+Type\\s*:\\s*video/}mi;\n}\n\nsub collect_video ($file, $directory) {\n\n    my $dest = catfile($directory, basename($file));\n\n    if (-e $dest) {\n        warn \"File <<$dest>> already exists...\\n\";\n        return;\n    }\n\n    move($file, $dest);\n}\n\nmy @dirs = @ARGV;\n\n@dirs || die \"usage: perl $0 [directory | files]\\n\";\n\nmy $directory = rel2abs(\"Videos\");    # directory where to move the videos\n\nif (not -d $directory) {\n    make_path($directory)\n      or die \"Can't create directory <<$directory>>: $!\";\n}\n\nif (not -d $directory) {\n    die \"<<$directory>> is not a directory!\";\n}\n\nfind(\n    {\n     wanted => sub {\n         if (-f $_ and is_video($_)) {\n             say \":: Moving video: $_\";\n             collect_video($_, $directory);\n         }\n     },\n    },\n    @dirs\n);\n"
  },
  {
    "path": "File Workers/delete_if_exists.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# https://github.com/trizen\n\n#\n# Delete files from $delete_dir if exists in $compare_dir (or its sub-directories)\n#\n# Usage: perl delete_if_exists.pl /delete/dir /compare/dir\n#\n\nuse strict;\nuse warnings;\n\nuse File::Find qw(find);\nuse File::Spec::Functions qw(rel2abs catdir);\n\nmy $delete_dir = rel2abs(shift);\nmy $compare_dir = rel2abs(shift || die \"usage: $0 [delete_dir] [compare_dir]\\n\");\n\nfind sub {\n    return unless -f;\n    my $delete_file = catdir($delete_dir, $_);\n    if (-f $delete_file) {\n        print unlink($delete_file)\n          ? \"** Deleted: $delete_file\\n\"\n          : \"[!] Can't delete $delete_file: $!\\n\";\n    }\n} => $compare_dir;\n"
  },
  {
    "path": "File Workers/dir_file_updater.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 04 November 2012\n# https://github.com/trizen\n\n# Update files in a directory, with files from other dirs.\n# Example: perl dir_file_updater.pl -o /tmp /root\n# /tmp/file.txt is updated with the newest file from the /root dir,\n# or it's sub-directories, called file.txt, but only if the file is newer\n# than the file from the /tmp dir. This script updates only the files from\n# the OUTPUT_DIR, without checking it's sub-directories.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse File::Copy qw(copy);\nuse File::Find qw(find);\nuse Getopt::Std qw(getopts);\nuse File::Compare qw(compare);\nuse File::Spec::Functions qw(rel2abs catfile);\n\nmy %opts;\ngetopts('o:', \\%opts);\n\nsub usage {\n    die <<\"EOH\";\nusage: $0 [options] [dirs]\n\noptions:\n        -o <output_dir>  : update files in this directory\n\nexample: $0 -o /my/path/out /my/path/input\nEOH\n}\n\nmy $output_dir = $opts{o};\n\nif (   not defined $output_dir\n    or not -d $output_dir\n    or not @ARGV) {\n    usage();\n}\n\n$output_dir = rel2abs($output_dir);\n\nmy %table;\n\nsub update_files {\n    my $file = $File::Find::name;\n    return unless -f $file;\n\n    if (not exists $table{$_} or -M ($table{$_}) > -M ($file)) {\n        $table{$_} = $file;\n    }\n}\n\nmy @dirs;\nforeach my $dir (@ARGV) {\n    if (not -d -r $dir) {\n        warn \"[!] Invalid dir '$dir': $!\\n\";\n        next;\n    }\n    push @dirs, rel2abs($dir);\n}\n\nfind {wanted => \\&update_files,} => @dirs;\n\nopendir(my $dir_h, $output_dir)\n  or die \"Can't read dir '$output_dir': $!\\n\";\n\nwhile (defined(my $file = readdir($dir_h))) {\n    next if $file eq q{.} or $file eq q{..};\n    my $filename = catfile($output_dir, $file);\n    next unless -f $filename;\n\n    if (exists $table{$file}) {\n        if (-M ($table{$file}) < -M ($filename)\n            and compare($table{$file}, $filename) != 0) {\n            say \"Updating: $table{$file} -> $filename\";\n            copy($table{$file}, $filename) or do { warn \"[!] Copy failed: $!\\n\" };\n        }\n    }\n}\n\nclosedir $dir_h;\n"
  },
  {
    "path": "File Workers/file-mover.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 23 August 2015\n# Website: https://github.com/trizen\n\n# Sort and move a list of file names into a given directory\n\nuse 5.016;\nuse strict;\nuse warnings;\n\nuse open IO => ':utf8', ':std';\n\nuse File::Copy qw(move);\nuse File::Basename qw(basename);\nuse File::Spec::Functions qw(catfile);\nuse Getopt::Long qw(GetOptions);\n\nmy $reverse = 0;         # bool\nmy $sort_by = 'none';    # string\nmy $output_dir;          # string\nmy $move = 'none';       # string\n\nmy %sorts = (\n             none   => sub { },\n             name   => sub { $a cmp $b },\n             iname  => sub { fc($a) cmp fc($b) },\n             length => sub { length($a) <=> length($b) },\n             size   => sub { (-s $a) <=> (-s $b) },\n             atime  => sub { (stat($a))[8] <=> (stat($b))[8] },\n             mtime  => sub { (stat($a))[9] <=> (stat($b))[9] },\n             ctime  => sub { (stat($a))[10] <=> (stat($b))[10] },\n            );\n\nsub help {\n    print <<\"EOT\";\nusage: $0 [options] < [input.txt]\n\noptions:\n    -s  --sort-by=s     : sort the files by:\n                            name   -> sort by filename\n                            iname  -> sort by filename case-insensitively\n                            length -> sort by the length of the filename\n                            size   -> sort by the size of the file\n                            atime  -> sort by file access time\n                            mtime  -> sort by file modification time\n                            ctime  -> sort by file inode change time\n                            none   -> don't do any sorting (default)\n\n    -r  --reverse!      : reverse the sorting\n    -o  --out-dir=s     : move the files into this directory\n    -m  --move=s        : move the files as follows:\n                            first  -> moves the first n-1 files\n                            last   -> moves the last n-1 files\n                            all    -> moves all files\n                            none   -> don't move any file (default)\n\nexample:\n    $0 --sort-by=mtime --move=last --out-dir=/tmp < files.txt\nEOT\n    exit 0;\n}\n\nGetOptions(\n           'm|move=s'           => \\$move,\n           'r|reverse!'         => \\$reverse,\n           'o|out-dir=s'        => \\$output_dir,\n           's|sort-by|sortby=s' => \\$sort_by,\n           'h|help'             => \\&help,\n          )\n  or die(\"error in command line arguments\");\n\nmy $sort_code = $sorts{lc($sort_by)} // die \"Invalid value `$sort_by' for option `--sort-by'\";\n\nif ($move ne 'none') {\n    if (defined($output_dir)) {\n        if (not -d $output_dir) {\n            die \"Invalid value `$output_dir' for option `--out-dir' (requires an existent directory)\";\n        }\n    }\n    else {\n        die \"Please add the `--out-dir' option, in order to `--move` files\";\n    }\n}\n\nsub process_files {\n    my (@files) = @_;\n\n    @files = do {\n        my %seen;\n        grep { !$seen{$_}++ } @files;\n    };\n\n    if ($sort_by ne 'none') {\n        @files = sort $sort_code @files;\n    }\n\n    if ($reverse) {\n        @files = reverse(@files);\n    }\n\n    my @all_files = @files;\n\n    if ($move eq 'none') {\n        @files = ();\n    }\n    elsif ($move eq 'first') {\n        @files = @files[0 .. $#files - 1];\n    }\n    elsif ($move eq 'last') {\n        @files = @files[1 .. $#files];\n    }\n    elsif ($move eq 'all') {\n        ## ok\n    }\n    else {\n        die \"Invalid value `$move' for `--move`\";\n    }\n\n    my %table;\n    @table{@files} = ();\n\n    foreach my $file (@all_files) {\n        print $file;\n        if (exists $table{$file}) {\n            my $basename = basename($file);\n            my $dest = catfile($output_dir, $basename);\n\n            print \" -> $dest\";\n\n            if (-e $dest) {\n                print \" (error: already exists)\";\n            }\n            else {\n                if (move($file, $dest)) {\n                    print \" (OK)\";\n                }\n                else {\n                    print \" (error: $!)\";\n                }\n            }\n        }\n        print \"\\n\";\n    }\n\n    if (@all_files) {\n        say \"-\" x 80;\n    }\n}\n\nmy @files;\nwhile (defined(my $line = <>)) {\n    chomp($line);\n\n    if (-e $line) {\n        push @files, $line;\n    }\n    elsif (@files) {\n        process_files(@files);\n        @files = ();\n    }\n}\n\nprocess_files(@files) if @files;\n"
  },
  {
    "path": "File Workers/file_updater.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 04 November 2012\n# https://github.com/trizen\n\n# Update files in a directory, with files from other dirs.\n# Example: perl file_updater.pl -o /tmp /root\n# /tmp/dir/file.txt is updated with /root/dir/file.txt\n# if the file from the /root dir is newer than the file from the /tmp dir.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse File::Copy qw(copy);\nuse File::Find qw(find);\nuse Getopt::Std qw(getopts);\nuse File::Compare qw(compare);\nuse File::Spec::Functions qw(rel2abs catfile);\n\nmy %opts;\ngetopts('o:', \\%opts);\n\nsub usage {\n    die <<\"EOH\";\nusage: $0 [options] [dirs]\n\noptions:\n        -o <output_dir>  : update files in this directory\n\nexample: $0 -o /my/path/out /my/path/input\nEOH\n}\n\nmy $output_dir = $opts{o};\n\nif (   not defined $output_dir\n    or not -d $output_dir\n    or not @ARGV) {\n    usage();\n}\n\n$output_dir = rel2abs($output_dir);\n\nmy @dirs;\nforeach my $dir (@ARGV) {\n    if (not -d -r $dir) {\n        warn \"[!] Invalid dir '$dir': $!\\n\";\n        next;\n    }\n    push @dirs, rel2abs($dir);\n}\n\nsub update_files {\n\n    return if $_ eq $output_dir;\n    return unless -f;\n\n    my $filename = substr($_, length($output_dir) + 1);\n    my $mdays = -M _;\n\n    foreach my $dir (@dirs) {\n        my $file = catfile($dir, $filename);\n        if (-e $file and -M (_) < $mdays and compare($file, $_) == 1) {\n            say \"Updating: $file -> $_\";\n            copy($file, $_) or do { warn \"[!] Copy failed: $!\\n\" };\n        }\n    }\n}\n\nfind {\n      no_chdir => 1,\n      wanted   => \\&update_files,\n     } => $output_dir;\n"
  },
  {
    "path": "File Workers/filename_cmp_del.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 16 June 2014\n# Website: https://github.com/trizen\n\n# Delete files from [del dir] which does NOT exists in [cmp dir]\n# NOTE: Only the base names are compared, without their extensions!\n\nuse 5.014;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse Getopt::Std qw(getopts);\nuse File::Spec::Functions qw(catfile);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOT\";\nusage: $0 [options] [cmp dir] [del dir]\n\noptions:\n        -d      : delete the files\n        -h      : print this message\n\nexample:\n    $0 -d /my/cmp_dir /my/del_dir\nEOT\n    exit $code;\n}\n\n# Options\ngetopts('dh', \\my %opt);\n$opt{h} and usage(0);\n\n# Dirs\n@ARGV == 2 or usage(2);\n\nmy $cmp_dir = shift;\nmy $del_dir = shift;\n\nmy $rem_suffix = qr/\\.\\w{1,5}\\z/;\n\n# Read the [cmp dir] and store the filenames in %cmp\nmy %cmp;\nopendir(my $cmp_h, $cmp_dir);\nwhile (defined(my $file = readdir($cmp_h))) {\n    my $abs_path = catfile($cmp_dir, $file);\n    if (-f $abs_path) {\n        undef $cmp{$file =~ s/$rem_suffix//r};\n    }\n}\nclosedir($cmp_h);\n\n# Delete each file which doesn't exists in [cmp dir]\nopendir(my $del_h, $del_dir);\nwhile (defined(my $file = readdir($del_h))) {\n    my $abs_path = catfile($del_dir, $file);\n    if (-f $abs_path) {\n        my $name = $file =~ s/$rem_suffix//r;\n        if (not exists $cmp{$name}) {\n            say $abs_path;\n            unlink $abs_path if $opt{d};\n        }\n    }\n}\nclosedir($del_h);\n"
  },
  {
    "path": "File Workers/keep_this_formats.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 12 September 2012\n# Edit: 11 August 2017\n# https://github.com/trizen\n\n# Keep only one or more type of file formats in a directory and its sub-directories.\n# List and remove the other formats (when -r is specified).\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse File::Find qw(find);\nuse Getopt::Std qw(getopts);\n\nsub usage {\n    die <<\"USAGE\";\nusage: $0 [options] <dirs>\n\noptions:\n        -f <formats> : the list of formats (comma separated)\n        -r           : remove the other formats (default: off)\n\nexample: $0 -f 'mp3,ogg,wma' /home/Music\nUSAGE\n}\n\nmy %opts;\ngetopts('f:r', \\%opts);\n\n$opts{f} // usage();\n@ARGV || usage();\n\nmy $formats_re = do {\n    local $\" = '|';\n    my @a = map { quotemeta } split(/\\s*,\\s*/, $opts{f});\n    qr/\\.(?:@a)\\z/i;\n};\n\nfind {\n    wanted => sub {\n        if (not /$formats_re/ and -f) {\n            say $_;\n            if ($opts{r}) {\n                unlink($_) or warn \"Can't remove file '$_': $!\";\n            }\n        }\n    },\n    no_chdir => 1,\n} => @ARGV;\n"
  },
  {
    "path": "File Workers/make_filenames_portable.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 16 June 2014\n# Website: https://github.com/trizen\n\n# Replace unsafe characters with safe characters in filenames\n# making the files portable to another FS (like FAT32)\n\nuse 5.014;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse Getopt::Std qw(getopts);\nuse File::Spec::Functions qw(catfile);\n\nsub usage {\n    my ($code) = @_;\n\n    print <<\"EOT\";\nusage: $0 [options] [dir1] [dir2] [...]\n\noptions:\n        -r      : rename the files\n        -h      : print this message\n\nexample:\n    $0 -r /my/dir\nEOT\n\n    exit $code;\n}\n\n# Parse arguments\ngetopts('rh', \\my %opt);\n\nusage(0) if $opt{h};\nusage(2) if !@ARGV;\n\n# Iterate over directories\nwhile (defined(my $dir = shift @ARGV)) {\n    opendir(my $dir_h, $dir);\n    while (defined(my $file = readdir($dir_h))) {\n        my $orig_name = catfile($dir, $file);\n        if (-f $orig_name and $file =~ tr{:\"*/?\\\\|}{;'+%$%%}) {\n            my $new_name = catfile($dir, $file);\n            say \"$orig_name -> $new_name\";\n            rename($orig_name, $new_name) if $opt{r};\n        }\n    }\n    closedir($dir_h);\n}\n"
  },
  {
    "path": "File Workers/md5_rename.pl",
    "content": "#!/usr/bin/perl\n\n# Rename files to their MD5 hex value in a given directory (and its subdirectories).\n\n# Example:\n#   \"IMG_20231024_094115.jpg\" becomes \"571b4ba928ae62e103b54727721ebe56.jpg\"\n\nuse 5.036;\nuse Digest::MD5           qw();\nuse File::Find            qw(find);\nuse File::Basename        qw(dirname basename);\nuse File::Spec::Functions qw(catfile);\n\nsub md5_rename_file ($file) {\n\n    open my $fh, '<:raw', $file or return;\n\n    my $ctx = Digest::MD5->new;\n    $ctx->addfile($fh);\n    my $digest = $ctx->hexdigest;\n\n    close $fh;\n\n    my $dirname  = dirname($file);\n    my $basename = basename($file);\n\n    if ($basename =~ s{^.*\\.(\\w+)\\z}{$digest.$1}s) {\n        ## ok\n    }\n    else {\n        $basename = $digest;\n    }\n\n    my $new_file = catfile($dirname, $basename);\n\n    if (-e $new_file) {    # new file already exists\n        return;\n    }\n\n    rename($file, $new_file) or return;\n    return $basename;\n}\n\nmy @dirs = @ARGV;\n\n@dirs || die \"usage: $0 [files | dirs]\\n\";\n\nfind(\n    {\n     wanted => sub {\n         if (-f $_) {\n\n             say \":: Renaming file: $_\";\n             my $basename = md5_rename_file($_);\n\n             if (defined($basename)) {\n                 say \"-> renamed to: $basename\";\n             }\n             else {\n                 say \"-> failed to rename...\";\n             }\n         }\n     },\n    },\n    @dirs\n);\n"
  },
  {
    "path": "File Workers/multiple_backups.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 11 September 2023\n# https://github.com/trizen\n\n# Create multiple backups of a list of filenames and update them as necessary.\n\nuse 5.036;\nuse Getopt::Long;\nuse File::Basename        qw(basename);\nuse File::Copy            qw(copy);\nuse File::Spec::Functions qw(catfile curdir);\n\nmy $backup_dir = curdir();\n\nsub usage ($exit_code = 0) {\n    print <<\"EOT\";\nusage: $0 [options] [filenames]\n\noptions:\n    --dir=s : directory where to save the backups (default: $backup_dir)\nEOT\n    exit($exit_code);\n}\n\nGetOptions(\"d|dir=s\" => \\$backup_dir,\n           'h|help'  => sub { usage(0) },)\n  or die(\"Error in command line arguments\\n\");\n\nmy %timestamps = (\n                  \"1h\"  => 1 / 24,\n                  \"1d\"  => 1,\n                  \"3d\"  => 3,\n                  \"30d\" => 30,\n                  \"1y\"  => 365,\n                 );\n\n@ARGV || usage(2);\n\nforeach my $file (@ARGV) {\n    say \":: Processing: $file\";\n    foreach my $key (sort keys %timestamps) {\n        my $checkpoint_time = $timestamps{$key};\n        my $backup_file     = catfile($backup_dir, basename($file) . '.' . $key);\n        if (not -e $backup_file or ((-M $backup_file) >= $checkpoint_time)) {\n            say \"   > writing backup: $backup_file\";\n            copy($file, $backup_file)\n              or warn \"Can't copy <<$file>> to <<$backup_file>>: $!\";\n        }\n    }\n}\n"
  },
  {
    "path": "File Workers/remove_eof_newlines.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Remove newline characters from the end of files\n\n# WARNING: No backup files are created!\n\nuse strict;\nuse warnings;\nuse Tie::File;\n\nforeach my $filename (grep { -f } @ARGV) {\n\n    print \"** Processing $filename\\n\";\n\n    tie my @file, 'Tie::File', $filename\n        or die \"Unable to tie: $!\\n\";\n\n    pop @file while $file[-1] eq q{};\n\n    untie @file\n        or die \"Unable to untie: $!\\n\";\n\n    print \"** Done.\\n\\n\";\n}\n"
  },
  {
    "path": "File Workers/split_to_n_lines.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Website: https://github.com/trizen\n\n# Split a text file into sub files of 'n' lines each other\n\nuse strict;\nuse warnings;\n\nuse Getopt::Std qw(getopts);\nuse File::Spec::Functions qw(catfile);\n\nmy %opts;\ngetopts('l:', \\%opts);\n\nmy $lines_n = $opts{l} ? int($opts{l}) : 100;\n\nif (not @ARGV) {\n    die \"Usage: $0 -l [i] <files>\\n\";\n}\n\nsub print_to_file {\n    my ($array_ref, $foldername, $num) = @_;\n    open(my $out_fh, '>', catfile($foldername, \"$num.txt\")) or return;\n    print $out_fh @{$array_ref};\n    close $out_fh;\n    return 1;\n}\n\nforeach my $filename (@ARGV) {\n\n    -f $filename or do {\n        warn \"$0: skipping '$filename': is not a file\\n\";\n        next;\n    };\n\n    my $foldername = $filename;\n    if (not $foldername =~ s/\\.\\w{1,5}$//) {\n        $foldername .= '_files';\n    }\n\n    if (-d $foldername) {\n        warn \"$0: directory '${foldername}' already exists...\\n\";\n        next;\n    }\n    else {\n        mkdir $foldername or do {\n            warn \"$0: Can't create directory '${foldername}': $!\\n\";\n            next;\n        };\n    }\n\n    open my $fh, '<', $filename or do {\n        warn \"$0: Can't open file '${filename}' for read: $!\\n\";\n        next;\n    };\n\n    my @lines;\n    my $num = 0;\n    while (defined(my $line = <$fh>)) {\n\n        push @lines, $line;\n\n        if (@lines == $lines_n or eof $fh) {\n            print_to_file(\\@lines, $foldername, ++$num);\n            undef @lines;\n        }\n    }\n    close $fh;\n}\n"
  },
  {
    "path": "File Workers/sub_renamer.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 1st December 2014\n# License: GPLv3\n# https://github.com/trizen\n\nuse utf8;\nuse 5.014;\nuse strict;\nuse warnings;\n\nuse Encode qw(decode_utf8);\nuse File::Find qw(find);\nuse Getopt::Long qw(GetOptions);\n\nbinmode(STDOUT, ':utf8');\n\nmy $rename         = 0;\nmy $single_file    = 0;\nmy $min_percentage = 50;\n\nsub help {\n    my ($code) = @_;\n\n    print <<\"HELP\";\nRename subtitles to match the video files\n\nusage: $0 /my/videos [...]\n\noptions:\n    -r --rename         : rename the file names (default: $rename)\n    -s --single-file    : one video and one subtitle in a dir (default: $single_file)\n    -p --percentage=i   : minimum percentage of approximation (default: $min_percentage)\n\nMatch subtitles to video names across directories and rename them accordingly.\nThe match is done heuristically, using an approximation comparison algorithm.\n\nWhen there are more subtitles and more videos inside a directory, the script\nmakes decisions based on the filename approximations and rename the file\nif they are at least 50% similar. (this percent is customizable)\n\nThe script has, also, several special cases for serials (S00E00)\nand for single video files with one subtitle in the same directory.\n\nUsage example:\n    $0 -s -p=75 ~/Videos\n\nCopyright (C) 2014 Daniel \"Trizen\" Șuteu <trizenx\\@gmail\\.com>\nLicense: GPLv3 or later, at your choice. See <https://www.gnu.org/licenses/gpl>\nHELP\n\n    exit($code // 0);\n}\n\nGetOptions(\n           'p|percentage=i' => \\$min_percentage,\n           'r|rename!'      => \\$rename,\n           's|single-file!' => \\$single_file,\n           'h|help'         => sub { help() },\n          )\n  or die(\"Error in command line arguments\");\n\nmy @dirs = grep { -d } @ARGV;\n@dirs || help(2);\n\n# Source: https://en.wikipedia.org/wiki/Video_file_format\nmy @video_formats = qw(\n  avi\n  mp4\n  wmv\n  mkv\n  webm\n  flv\n  ogv\n  ogg\n  drc\n  mng\n  mov\n  qt\n  rm\n  rmvb\n  asf\n  m4p\n  m4v\n  mpg\n  mp2\n  mpeg\n  mpe\n  mpv\n  m4v\n  3gp\n  3g2\n  mxf\n  roq\n  nsv\n  yuv\n  );\n\n# Source: https://en.wikipedia.org/wiki/Subtitle_%28captioning%29#Subtitle_formats\nmy @subtitle_formats = qw(\n  aqt\n  gsub\n  jss\n  sub\n  ttxt\n  pjs\n  psb\n  rt\n  smi\n  stl\n  ssf\n  srt\n  ssa\n  ass\n  usf\n  );\n\nsub acmp {\n    my ($name1, $name2, $percentage) = @_;\n\n    my ($len1, $len2) = (length($name1), length($name2));\n    if ($len1 > $len2) {\n        ($name2, $len2, $name1, $len1) = ($name1, $len1, $name2, $len2);\n    }\n\n    return -1\n      if (my $min = int($len2 * $percentage / 100)) > $len1;\n\n    my $diff = $len1 - $min;\n    foreach my $i (0 .. $diff) {\n        foreach my $j ($i .. $diff) {\n            if (index($name2, substr($name1, $i, $min + $j - $i)) != -1) {\n                return 0;\n            }\n        }\n    }\n\n    return 1;\n}\n\nmy $videos_re = do {\n    local $\" = '|';\n    qr/\\.(?:@video_formats)\\z/i;\n};\n\nmy $subs_re = do {\n    local $\" = '|';\n    qr/\\.(?:@subtitle_formats)\\z/i;\n};\n\nmy $serial_re = qr/S([0-9]{2,})E([0-9]{2,})/;\n\nif (not $rename) {\n\n    warn \"\\n[!] To actually rename the files, execute me with option '-r'.\\n\\n\";\n\n}\n\nmy %content;\nfind {\n    no_chdir => 0,\n    wanted   => sub {\n        if (/$videos_re/) {\n            my $name = decode_utf8($_) =~ s/$videos_re//r;\n            push @{$content{$File::Find::dir}{videos}{$name}}, decode_utf8($File::Find::name);\n        }\n        elsif (/$subs_re/) {\n            my $name = decode_utf8($_) =~ s/$subs_re//r;\n            push @{$content{$File::Find::dir}{subs}{$name}}, decode_utf8($File::Find::name);\n        }\n    },\n} => @dirs;\n\nsub ilc {\n    my ($string) = @_;\n    $string =~ s/[[:punct:]]+/ /g;\n    $string = join(' ', split(' ', $string));\n    lc($string);\n}\n\nforeach my $dir (sort keys %content) {\n    my $subs   = $content{$dir}{subs}   // next;\n    my $videos = $content{$dir}{videos} // next;\n\n    # Make a table with scores and rename the subtitles\n    # accordingly to each video it belongs (using heuristics)\n    my (%table, %seen, %subs_taken);\n\n    my @subs   = sort keys %{$subs};\n    my @videos = sort keys %{$videos};\n\n    my %memo;\n    foreach my $sub (@subs) {\n        foreach my $video (@videos) {\n          PERCENT: for (my $i = 100 ; $i >= $min_percentage ; $i--) {\n\n                # Break if subtitle has the same name as video\n                # and mark it as already taken.\n                if ($sub eq $video) {\n                    $subs_taken{$sub}++;\n                    last;\n                }\n\n                if (acmp($memo{$sub} //= ilc($sub), $memo{$video} //= ilc($video), $i) == 0) {\n\n                    # A subtitle can't be shared with more videos\n                    if (exists $seen{$sub}) {\n                        foreach my $key (@{$seen{$sub}}) {\n                            if (@{$table{$key}}) {\n                                if ($i > $table{$key}[-1][1]) {\n                                    pop @{$table{$key}};\n                                }\n                                else {\n                                    last PERCENT;\n                                }\n                            }\n                        }\n                    }\n\n                    push @{$table{$video}}, [$sub, $i];\n                    push @{$seen{$sub}}, $video;\n                    last;\n                }\n            }\n        }\n    }\n\n    if (@subs == 1 and @videos == 1 and not keys %table) {\n        my ($sub, $video) = (@subs, @videos);\n        next if $sub eq $video;\n        $table{$video} = [[$sub, 0]];\n    }\n\n    # Rename the files\n    foreach my $video (sort keys %table) {\n        @{$table{$video}} || next;\n        my ($sub, $percentage) = @{(sort { $b->[1] <=> $a->[1] } @{$table{$video}})[0]};\n\n        next if exists $subs_taken{$sub};\n\n        foreach my $subfile (@{$subs->{$sub}}) {\n\n            # If it is a serial (SxxExx)\n            # skip if subtitle contains a serial number\n            # that is different from that of the video.\n            if ($video =~ /$serial_re/) {\n                my ($vs, $ve) = ($1, $2);\n                if ($sub =~ /$serial_re/) {\n                    my ($ss, $se) = ($1, $2);\n                    if ($vs ne $ss or $ve ne $se) {\n                        next;\n                    }\n                }\n            }\n\n            my $new_name = $subfile =~ s/\\Q$sub\\E(?=$subs_re)/$video/r;\n            say \"** Renaming: $subfile -> $new_name ($percentage%)\";\n\n            # Skip file if the current percentage is lower than the minimum percentage\n            if ($percentage < $min_percentage) {\n                if (@subs == 1 and @videos == 1) {\n                    if (not $single_file) {\n                        warn \"\\t[!] I will rename this if you execute me with option '-s'.\\n\";\n                        next;\n                    }\n                }\n                else {    # this will not happen\n                    warn \"\\t[!] Percentage is lower than $min_percentage%. Skipping file...\\n\";\n                    next;\n                }\n            }\n\n            # Rename the file (if rename is enabled)\n            if ($rename) {\n\n                if (-e $new_name) {\n                    warn \"\\t[!] File already exists... Skipping...\\n\";\n                    next;\n                }\n\n                rename($subfile, $new_name)\n                  || warn \"\\t[!] Can't rename file: $!\\n\";\n            }\n        }\n    }\n}\n"
  },
  {
    "path": "File Workers/timestamp_rename.pl",
    "content": "#!/usr/bin/perl\n\n# Rename files to their MD5 hex value in a given directory (and its subdirectories).\n\n# Example:\n#   \"IMG_20231024_094115.jpg\" becomes \"571b4ba928ae62e103b54727721ebe56.jpg\"\n\nuse 5.036;\nuse Digest::MD5           qw();\nuse File::Find            qw(find);\nuse File::Basename        qw(dirname basename);\nuse File::Spec::Functions qw(catfile);\n\nsub md5_rename_file ($file) {\n\n    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,\n                        $atime,$mtime,$ctime,$blksize,$blocks)\n                                               = stat($file);\n\n    my $dirname  = dirname($file);\n    my $basename = basename($file);\n\n    if ($basename =~ s{^.*\\.(\\w+)\\z}{$ctime.$1}s) {\n        ## ok\n    }\n    else {\n        $basename = $ctime;\n    }\n\n    my $new_file = catfile($dirname, $basename);\n\n    if (-e $new_file) {    # new file already exists\n        return;\n    }\n\n    rename($file, $new_file) or return;\n    return $basename;\n}\n\nmy @dirs = @ARGV;\n\n@dirs || die \"usage: $0 [files | dirs]\\n\";\n\nfind(\n    {\n     wanted => sub {\n         if (-f $_) {\n\n             say \":: Renaming file: $_\";\n             my $basename = md5_rename_file($_);\n\n             if (defined($basename)) {\n                 say \"-> renamed to: $basename\";\n             }\n             else {\n                 say \"-> failed to rename...\";\n             }\n         }\n     },\n    },\n    @dirs\n);\n"
  },
  {
    "path": "File Workers/undir.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 10th August 2014\n# Website: https://github.com/trizen\n\n# Move all the files from a directory's sub-directories into the main directory (with depth control)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Getopt::Std qw(getopts);\n\nuse File::Copy qw(move);\nuse File::Find qw(find);\nuse File::Basename qw(basename);\nuse File::Spec::Functions qw(catfile splitdir);\n\nsub usage {\n    my ($code) = @_;\n\n    print <<\"USAGE\";\nusage: $0 [options] [dirs]\n\noptions:\n        -u     : undir the files\n        -d     : delete empty directories\n        -t int : depth limit (default: unlimited)\n\nexample:\n     $0 -u -t 2 /my/dir\nUSAGE\n\n    exit($code // 0);\n}\n\ngetopts('udht:', \\my %opt);\n$opt{h} && usage(0);\n\nmy @dirs = grep { -d } @ARGV;\n@dirs || usage(2);\n\nforeach my $dir (@dirs) {\n\n    my $depth = splitdir($dir);\n\n    my %dirs;\n    my @files;\n    find(\n        {\n         no_chdir => 1,\n         wanted   => sub {\n             return if $File::Find::dir eq $dir;\n             if (defined $opt{t}) {\n                 return if (splitdir($File::Find::dir) - $depth > $opt{t});\n             }\n             $dirs{$File::Find::dir} //= 1;\n             push @files, $_ if -f;\n           }\n        } => $dir\n    );\n\n    my $error = 0;\n    foreach my $file (@files) {\n        say $file;\n        if ($opt{u}) {\n            my $basename = basename($file);\n            my $newfile = catfile($dir, $basename);\n            if (-e $newfile) {\n                warn \"File `$basename' already exists in dir `$dir'...\";\n                ++$error;\n            }\n            else {\n                move($file, $newfile) || do {\n                    warn \"Can't move file `$file' to `$newfile': $!\";\n                    ++$error;\n                };\n            }\n        }\n    }\n\n    if ($error == 0 and $opt{d}) {\n        foreach my $key (keys %dirs) {\n            rmdir($key);\n        }\n    }\n}\n"
  },
  {
    "path": "File Workers/unidec_renamer.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 29 October 2012\n# Edit: 23 June 2013\n# https://github.com/trizen\n\n# Unidecode filename renamer.\n# Ex: fișier.mp3 -> fisier.mp3\n\n# Usage: unidec_renamer.pl -r <dirs>\n\nuse utf8;\nuse 5.005;\nuse strict;\nuse warnings;\n\nuse File::Find qw(find);\nuse Getopt::Std qw(getopts);\nuse File::Basename qw(basename);\nuse Text::Unidecode qw(unidecode);\nuse File::Spec::Functions qw(catfile catdir splitdir);\n\nmy %opts;\ngetopts('r', \\%opts);\n\nmy @dirs = grep { -d } @ARGV;\n@dirs || die \"usage: $0 [-r] <dir>\\n\";\n\nbinmode(STDOUT, ':utf8');\n\nsub unidec_rename_file {\n    my ($filename, $new_filename) = @_;\n\n    if (not -e $new_filename) {\n        rename $filename, $new_filename\n          or do { warn \"Can't rename: $!\\n\"; return };\n    }\n    else {\n        warn \"'$new_filename' already exists! Skipping...\\n\";\n    }\n    return 1;\n}\n\nmy @dirs_for_rename;\nfind {\n    no_chdir => 1,\n    wanted   => sub {\n        my $filename = basename($File::Find::name);\n\n        utf8::decode($filename);\n        my $new_name = unidecode($filename);\n\n        if ($filename ne $new_name) {\n            my $dir = $File::Find::dir;\n            utf8::decode($dir);\n\n            print \"[\", qw(DIR FILE) [-f $_], \"] $filename -> $new_name\\n\";\n\n            my $new_filename = (-f _) ? catfile($dir, $new_name) : do {\n                push @dirs_for_rename, [$_, ($dir eq $filename ? $new_name : catdir($dir, $new_name))];\n                return;\n            };\n\n            if ($opts{r}) {\n                unidec_rename_file($_ => $new_filename);\n            }\n        }\n    },\n} => @dirs;\n\nif ($opts{r}) {\n    foreach my $array_ref (\n                           map  { $_->[1] }\n                           sort { $b->[0] <=> $a->[0] }\n                           map  { [scalar(splitdir($_->[0])), $_] } @dirs_for_rename\n      ) {\n        unidec_rename_file($array_ref->[0], $array_ref->[1]);\n    }\n}\n"
  },
  {
    "path": "Finders/ampath",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 27 December 2011\n# Edit: 18 February 2012\n# Edit: 16 November 2021\n# https://github.com/trizen\n\n# Find files which have the exact or almost the exact name in a path.\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse Getopt::Long;\n\nuse experimental qw(smartmatch);\n\nsub usage {\n    print <<\"HELP\";\nusage: $0 [options] [dir]\n\noptions:\n    --approx=i : amount of approximateness (default: 0)\n    --hidden!  : verify hidden files and folders (default: false)\n\nexample: $0 --approx=4 /my/dir\nHELP\n    exit 0;\n}\n\nmy $show_hidden_files;\nmy $approximate_n;\n\nGetOptions(\n           'approximate=i' => \\$approximate_n,\n           'hidden!'       => \\$show_hidden_files,\n           'help|h'        => \\&usage,\n          )\n  or die \"Error in command-line arguments!\";\n\nif (defined $approximate_n) {\n    $approximate_n += 1;\n}\n\nmy @files;\n\nsub locate_files {\n    foreach my $dir (@{$_[0]}) {\n        $dir = readlink $dir and chop $dir if -l $dir;\n        next unless opendir(my $dir_h, $dir);\n\n        my @dirs;\n        while (defined(my $file = readdir $dir_h)) {\n            if ($show_hidden_files) {\n                if ($file eq '.' || $file eq '..') {\n                    next;\n                }\n            }\n            else {\n                next if chr ord $file eq '.';\n            }\n            if (-d \"$dir/$file\") {\n                push @dirs, \"$dir/$file\";\n            }\n            elsif (-f _) {\n                push @files, {lc $file, \"$dir/$file\", 'file', lc $file};\n            }\n        }\n        closedir $dir_h;\n        locate_files(\\@dirs);\n    }\n}\n\nsub editdist {\n    my %h;\n    $h{$_}++ for split //, lc shift;\n    $h{$_}-- for split //, lc shift;\n    my $t = 0;\n    $t += ($_ > 0 ? $_ : -$_) for values %h;\n    $t;\n}\n\nsub find_similar_names {\n    my ($name, $array_ref) = @_;\n\n    my (@names) =\n      sort { $a->[1] <=> $b->[1] } grep { defined } map {\n        my $d = editdist($_, $name);\n        $d < $approximate_n ? [$_, $d] : undef;\n      } grep { $_ ne $name } @$array_ref;\n\n    if (@names) {\n        my $best = $names[0][1];\n        @names = map { $_->[0] } grep { $_->[1] == $best } @names;\n    }\n\n    \\@names;\n}\n\nsub diff {\n    my %alike;\n    my %table;\n    my @found;\n\n    if (defined $approximate_n) {\n        my (@names) = map { $_->{'file'} } @files;\n\n        foreach my $file (@files) {\n\n            my (@names) =\n              map { $_->{'file'} }\n              grep {\n\n                my $length_1 = length $_->{'file'};\n                my $length_2 = length $file->{'file'};\n\n                ($length_1 <= $length_2 + $approximate_n) and ($length_1 >= $length_2 - $approximate_n)\n                  or ($length_1 == $length_2)\n                  if ($_->{'file'} ne $file->{'file'});\n\n              } @files;\n\n            push @{$table{$file->{$file->{'file'}}}}, @{find_similar_names $file->{'file'}, \\@names};\n        }\n\n        foreach my $array_1_ref (values %table) {\n            next unless $array_1_ref;\n            while (my ($file, $array_2_ref) = each %table) {\n                if (@{$array_2_ref} and $array_1_ref ~~ $array_2_ref) {\n                    $alike{$file} = ();\n                }\n            }\n        }\n\n        return map { $_->[1] }\n          sort     { $a->[0] cmp $b->[0] }\n          map      { [lc(substr($_, rindex($_, '/'))), $_] }\n          keys %alike;\n    }\n\n    foreach my $file (@files, @files) {\n        $alike{$file->{$file->{'file'}}} = () if $table{$file->{'file'}}++ >= 2;\n    }\n\n    return map { $_->[1] }\n      sort     { $a->[0] cmp $b->[0] }\n      map      { [lc(substr($_, rindex($_, '/'))), $_] }\n      grep     { length } keys %alike;\n}\n\nforeach my $arg (@ARGV) {\n    $arg =~ s[(?<=.)/+$][];\n    my (@dir) = (-d $arg) ? $arg : next;\n    local $, = \"\\n\";\n    say diff(locate_files(\\@dir));\n    undef @files;\n}\n"
  },
  {
    "path": "Finders/dup_subtr_finder.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 11 December 2013\n# https://trizenx.blogspot.com\n\n# Find the longest duplicated sub-strings inside a string/file (based on a given minimum length).\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse List::Util qw(first);\nuse Data::Dump qw(pp);\nuse Getopt::Std qw(getopts);\n\nsub find_substrings (&@) {\n    my ($code, $str, $min) = @_;\n\n    my @substrings;\n    my $len = length($str);\n    my $max = int($len / 2);\n\n    my @pos;\n    for (my $i = $max ; $i >= $min ; $i--) {\n        for (my $j = 0 ; $j <= $len - $i * 2 ; $j++) {\n\n            #die $i if $i > ($len - ($j + $i));     # not gonna happen\n            #say \"=>> \", substr($str, $j, $i);\n\n            if (defined(my $arr = first { $j >= $_->[0] && $j <= $_->[1] } @pos)) {\n                $j = $arr->[1];\n                next;\n            }\n\n            if ((my $pos = index($str, substr($str, $j, $i), $j + $i)) != -1) {\n                $code->({pos => [$j, $pos], len => $i, substr => substr($str, $j, $i)});\n                push @pos, [$j, $j + $i];         # don't match again in substr\n                #push @pos, [$pos, $pos + $i];    # don't match again in dup-substr\n                $j += $i;\n            }\n        }\n    }\n\n=old\n    for (my $j = 0 ; $j <= $len ; $j++) {\n        for (my $i = $len - $j > $max ? $max : $len - $j ; $i >= $min ; $i--) {\n            next if $i > ($len - ($j + $i));\n            if ((my $pos = index($str, substr($str, $j, $i), $j + $i)) != -1) {\n                $code->({pos => [$j, $pos], len => $i, substr => substr($str, $j, $i)});\n                $j += $i;\n                last;\n            }\n        }\n    }\n=cut\n\n    return @substrings;\n}\n\n#\n## MAIN\n#\n\nsub usage {\n    print <<\"USAGE\";\nusage: $0 [options] [input-file]\n\noptions:\n        -m <int>  : the minimum sub-string length\n\nexample: perl $0 -m 50 file.txt\nUSAGE\n\n    exit 1;\n}\n\nmy %opt;\ngetopts('m:', \\%opt);\n\nmy $file = @ARGV && (-f $ARGV[0]) ? shift() : usage();\nmy $minLen = $opt{m} || (-s $file) / 10;\n\n# Dearly spider\nfind_substrings { say pp(shift) } (\n do {\n     local $/;\n     open my $fh, '<', $file;\n     <$fh>;\n },\n $minLen\n                                  );\n"
  },
  {
    "path": "Finders/fcheck.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 23th September 2013\n# https://trizenx.blogspot.com\n\n# Display all the files from a given directory with\n# size greater than N and modified in or after a given date.\n\n# usage: perl fcheck.pl [/my/dir] [MB size] [day.month.year]\n\nuse strict;\nuse warnings;\n\nuse File::Spec qw();\nuse File::Find qw(find);\nuse Time::Local qw(timelocal);\n\nmy $dir = @ARGV\n  ? shift()                  # first argument\n  : File::Spec->curdir();    # or current directory\n\nmy $min_size = @ARGV\n  ? shift() * 1024**2        # second argument\n  : 100 * 1024**2;           # 100MB\n\nmy $min_date = @ARGV\n  ? shift()                  # third argument\n  : '10.09.2013';            # 10th September 2013\n\n# Converting date into seconds\nmy ($mday, $mon, $year, $hour, $min, $sec) = split(/[\\s.:]+/, $min_date);\nmy $min_time = timelocal($sec, $min, $hour, $mday, $mon - 1, $year);\n\nsub check_file {\n    lstat;\n\n    -f _ or return;          # ignore non-files\n    -l _ and return;         # ignore links\n\n    (-s _) > $min_size or return;           # ignore smaller files\n    (stat(_))[9] >= $min_time or return;    # ignore older files\n\n    print \"$_\\n\";                           # we have a match\n}\n\nfind {no_chdir => 1, wanted => \\&check_file} => $dir;\n"
  },
  {
    "path": "Finders/fdf",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 01 January 2012\n# Edit: 24 August 2024\n# https://github.com/trizen\n\n# Find and list duplicate files from one or more paths, with options for\n# deleting or replacing duplicate files with symbolic links to the main file.\n\nuse 5.005;\nuse strict;\nuse warnings;\n\nuse File::Find     qw(find);\nuse File::Compare  qw(compare);\nuse File::Basename qw(basename);\nuse Getopt::Long   qw(GetOptions);\n\nmy %order_callbacks = (\n    path => sub { sort @_ },\n    name => sub {\n        map  { $_->[1] }\n        sort { $a->[0] cmp $b->[0] }\n        map  { [basename($_), $_] } @_;\n    },\n    time => sub {\n        map  { $_->[1] }\n        sort { $a->[0] <=> $b->[0] }\n        map  { [-M $_, $_] } @_;\n    },\n);\n\nmy @dirs = grep { (-d) or (-f) } @ARGV;\ndie <<\"HELP\" if !@dirs;\nusage: $0 [options] /my/path [...]\n\nOptions:\n  -f, --first      : keep only the first duplicated file\n  -l, --last       : keep only the last duplicated file\n  -s, --symlink    : replace duplicate files with symbolic links (with -f or -l)\n  -o, --order=type : order the results by: path, name or time\n  -m, --min-size=i : minimum size in bytes (default: 0)\n\nHELP\n\nmy $keep_first;\nmy $keep_last;\nmy $create_symlinks;\nmy $order_by = 'time';\nmy $min_size = 0;\n\nGetOptions(\n           'f|first!'           => \\$keep_first,\n           'l|last!'            => \\$keep_last,\n           's|symlink!'         => \\$create_symlinks,\n           'o|order|order-by=s' => \\$order_by,\n           'm|min-size=i'       => \\$min_size,\n          )\n  or die(\"$0: error in command line arguments\\n\");\n\nif (not exists $order_callbacks{$order_by}) {\n    local $\" = \", \";\n    die \"$0: invalid value `$order_by` for `--order`: valid values are: @{[sort keys %order_callbacks]}\\n\";\n}\n\nsub find_duplicated_files (&@) {\n    my $callback = shift;\n\n    my %files;\n    find {\n        no_chdir => 1,\n        wanted   => sub {\n            lstat;\n            (-f _) && (not -l _) && ((-s _) >= $min_size) && push @{$files{-s _}}, $_;\n        }\n    } => @_;\n\n    foreach my $files (values %files) {\n\n        next if $#{$files} < 1;\n\n        my %dups;\n        foreach my $i (0 .. $#{$files} - 1) {\n            for (my $j = $i + 1 ; $j <= $#{$files} ; $j++) {\n                if (compare($files->[$i], $files->[$j]) == 0) {\n                    push @{$dups{$files->[$i]}}, splice @{$files}, $j--, 1;\n                }\n            }\n        }\n\n        while (my ($fparent, $fdups) = each %dups) {\n            $callback->($order_callbacks{$order_by}($fparent, @{$fdups}));\n        }\n    }\n\n    return;\n}\n\n{\n    local $, = \"\\n\";\n    local $\\ = \"\\n\";\n\n    find_duplicated_files {\n        my (@files) = @_;\n\n        print @files, \"-\" x 80;\n\n        my $main_file = (\n                           $keep_first ? shift(@files)\n                         : $keep_last  ? pop(@files)\n                         :               return\n                        );\n\n        foreach my $file (@files) {\n\n            print \":: Removing: `$file`\";\n\n            unlink($file) or do {\n                warn \"error: can't delete file `$file': $!\\n\";\n                next;\n            };\n\n            if ($create_symlinks) {\n                print \":: Symlinking: `$main_file` <- `$file`\";\n                symlink($main_file, $file) or do {\n                    warn \"error: can't create symbolic link for `$file': $!\\n\";\n                    next;\n                };\n            }\n        }\n    } @dirs;\n}\n"
  },
  {
    "path": "Finders/fdf-attr",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 22 January 2012\n# https://github.com/trizen\n\n# Find files which have the same attributes\n\n#\n## WARNING! For strict duplicates, use the 'fdf' script:\n#   https://github.com/trizen/perl-scripts/blob/master/Finders/fdf\n#\n\nuse 5.005;\nuse strict;\nuse warnings;\n\nuse File::Find qw(find);\nuse Getopt::Std qw(getopts);\n\nmy @dirs = grep { -d } @ARGV;\ndie <<\"HELP\" if !@dirs;\nusage: $0 [options] /my/path [...]\n\nOptions:\n        -f  : keep only the first duplicated file\n        -l  : keep only the last duplicated file\nHELP\n\nmy %opts;\nif (@ARGV) {\n    getopts(\"fl\", \\%opts);\n}\n\nsub find_duplicated_files (&@) {\n    my $code = shift;\n\n    my %files;\n    find {\n        no_chdir => 1,\n        wanted   => sub {\n            lstat;\n            return if ((-s _) < 4 * 1024);  # skip files smaller than 4KB\n\n            (-f _)\n              && (not -l _)\n              && push @{\n                $files{\n                    join($;,\n                         (-r _), (-w _), (-x _), (-o _), (-R _), (-W _),\n                         (-X _), (-O _), (-s _), (-u _), (-g _), (-k _),\n                        )\n                      }\n              },\n              $_;\n          }\n         } => @_;\n\n    foreach my $files (values %files) {\n        next if $#{$files} < 1;\n        $code->(@{$files});\n    }\n\n    return;\n}\n\n{\n    local $, = \"\\n\";\n    local $\\ = \"\\n\";\n    find_duplicated_files {\n\n        print @_, \"-\" x 80 if @_;\n\n        foreach my $i (\n                         $opts{f} ? (1 .. $#_)\n                       : $opts{l} ? (0 .. $#_ - 1)\n                       :            ()\n          ) {\n            unlink $_[$i] or warn \"[error]: Can't delete: $!\\n\";\n        }\n    }\n    @dirs;\n}\n"
  },
  {
    "path": "Finders/fdf-filename",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 21 June 2012\n# https://github.com/trizen\n\n# Find and list duplicated files from one or more paths\n\n#\n## WARNING! For strict duplicates, use the 'fdf' script:\n#   https://github.com/trizen/perl-scripts/blob/master/Finders/fdf\n#\n\nuse 5.005;\nuse strict;\nuse warnings;\n\nuse File::Find qw(find);\nuse File::Basename qw(basename);\nuse Getopt::Std qw(getopts);\n\nmy @dirs = grep { -d } @ARGV;\ndie <<\"HELP\" if !@dirs;\nusage: $0 [options] /my/path [...]\n\nOptions:\n        -f  : keep only the first duplicated file\n        -l  : keep only the last duplicated file\nHELP\n\nmy %opts;\nif (@ARGV) {\n    getopts(\"fl\", \\%opts);\n}\n\nsub compare_strings ($$) {\n    my ($name1, $name2) = @_;\n\n    return 0 if $name1 eq $name2;\n\n    if (length($name1) > length($name2)) {\n        ($name2, $name1) = ($name1, $name2);\n    }\n\n    my $len1 = length($name1);\n    my $len2 = length($name2);\n\n    my $min = int(0.5 + $len2 / 2);\n    return -1 if $min > $len1;\n\n    my $diff = $len1 - $min;\n    foreach my $i (0 .. $diff) {\n        foreach my $j ($i .. $diff) {\n            if (index($name2, substr($name1, $i, $min + $j - $i)) != -1) {\n                return 0;\n            }\n        }\n    }\n\n    return 1;\n}\n\nsub find_duplicated_files (&@) {\n    my $code = shift;\n\n    my %files;\n    find {\n        no_chdir => 1,\n        wanted   => sub {\n            lstat;\n            return if ((-s _) < 4 * 1024);    # skips files smaller than 4KB\n            -f _ && (not -l _) && push @{$files{-s _}}, $_;\n          }\n         } => @_;\n\n    foreach my $files (values %files) {\n\n        next if $#{$files} < 1;\n\n        my %dups;\n        foreach my $i (0 .. $#{$files} - 1) {\n            for (my $j = $i + 1 ; $j <= $#{$files} ; $j++) {\n                if (compare_strings(basename($files->[$i]), basename($files->[$j])) == 0) {\n                    push @{$dups{$files->[$i]}}, splice @{$files}, $j--, 1;\n                }\n            }\n        }\n\n        while (my ($fparent, $fdups) = each %dups) {\n            $code->(sort $fparent, @{$fdups});\n        }\n    }\n\n    return;\n}\n\n{\n    local $, = \"\\n\";\n    local $\\ = \"\\n\";\n    find_duplicated_files {\n\n        print @_, \"-\" x 80 if @_;\n\n        foreach my $i (\n                         $opts{f} ? (1 .. $#_)\n                       : $opts{l} ? (0 .. $#_ - 1)\n                       :            ()\n          ) {\n            unlink $_[$i] or warn \"[error]: Can't delete: $!\\n\";\n        }\n    }\n    @dirs;\n}\n"
  },
  {
    "path": "Finders/file_binsearch.pl",
    "content": "#!/usr/bin/perl\n\n# Code from \"Mastering Algorithms with Perl\" book\n# derived from code by Nathan Torkington\n\n# Code improved by Daniel \"Trizen\" Șuteu\n# Added support for very large files and locale support\n\n# Date: 29 November 2013\n# Edit: 17 April 2023\n# https://github.com/trizen\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\n# Use locale when '-l' switch is specified\nuse if $#ARGV >= 0 && $ARGV[0] eq '-l' => 'locale';\n\n# Using Math::BigInt to work with very large files\nuse Math::BigInt try => 'GMP,Pari';\n\n# For parsing the command line switches\nuse Getopt::Std qw(getopts);\n\nmy %opts;\ngetopts('lnh', \\%opts);\n\nsub usage {\n    my ($code) = @_;\n\n    print <<\"USAGE\";\nusage: $0 [options] <line> <file>\n\noptions:\n        -l  : use the current locale for string comparisons\n        -n  : use numeric comparisons\n\nexample:\n        perl $0 -l \"hello world\" bigList.txt\nUSAGE\n\n    exit $code;\n}\n\nusage(0)  if $opts{h};\nusage(-1) if $#ARGV != 1;\n\nmy ($word, $file) = @ARGV;\n\nopen(my $fh, '<', $file);\nmy $position = binary_search_file($fh, $word);\n\nif   (defined $position) { print \"$word occurs at position $position\\n\" }\nelse                     { print \"$word does not occur in $file.\\n\" }\n\nsub compare {\n    my ($word1, $word2) = @_;\n\n    chomp $word1;\n    $opts{n} ? (Math::BigInt->new($word1) <=> Math::BigInt->new($word2)) : ($word1 cmp $word2);\n}\n\nsub binary_search_file {\n    my ($file, $word) = @_;\n\n    my $low  = Math::BigInt->new(0);           # Guaranteed to be the start of a line.\n    my $high = Math::BigInt->new(-s $file);    # Might not be the start of a line.\n\n    my $line;\n    while ($high != $low) {\n\n        my $mid = ($high + $low) >> 1;\n        seek($file, $mid, 0);\n\n        # $mid is probably in the middle of a line, so read the rest\n        # and set $mid2 to that new position.\n        scalar <$file>;\n        my $mid2 = Math::BigInt->new(tell($file));\n\n        if ($mid2 < $high) {    # We're not near file's end, so read on.\n            $mid  = $mid2;\n            $line = <$file>;\n        }\n        else {                  # $mid plunked us in the last line, so linear search.\n            seek($file, $low, 0);\n            while (defined($line = <$file>)) {\n                last if compare($line, $word) >= 0;\n                $low = Math::BigInt->new(tell($file));\n            }\n            last;\n        }\n\n        compare($line, $word) == -1\n          ? do { $low  = $mid }\n          : do { $high = $mid };\n    }\n\n    compare($line, $word) == 0\n      ? $low\n      : ();\n}\n"
  },
  {
    "path": "Finders/find_perl_scripts.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# License: GPLv3\n# Date: 15 March 2012\n\n# Find perl scripts in a directory and its subdirectories\n\nuse 5.010;\nuse File::Find qw(find);\n\nmy @dirs = grep { -d } @ARGV or die \"usage: $0 [dirs]\\n\";\n\nfind {\n    wanted => sub {\n        if (/\\.p[lm]$/i) { say }\n        elsif (-T and open my $fh, '<', $_) {\n            my $head = <$fh> || return;\n            if ($head =~ m{^\\s*#\\s*!.*\\bperl\\d*\\b}) { say }\n        }\n    },\n    no_chdir => 1\n}, @dirs\n"
  },
  {
    "path": "Finders/find_similar_filenames.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 22 June 2012\n# https://github.com/trizen\n\n# Find files which have exactly or *ALMOST*\n# exactly the same name in a given path.\n\n# Improved version here:\n#   https://github.com/trizen/perl-scripts/blob/master/Finders/fsfn.pl\n\nuse 5.014;\nuse strict;\nuse warnings;\n\nuse File::Find qw(find);\nuse Getopt::Std qw(getopts);\n\nmy @dirs = grep { -d } @ARGV;\ndie <<\"HELP\" if !@dirs;\nusage: $0 [options] /my/path [...]\n\nOptions:\n        -f  : keep only the first file\n        -l  : keep only the last file\n\nHELP\n\nmy %opts;\nif (@ARGV) {\n    getopts(\"fl\", \\%opts);\n}\n\nsub compare_strings ($$) {\n    my ($name1, $name2) = @_;\n\n    return 0 if $name1 eq $name2;\n\n    if (length($name1) > length($name2)) {\n        ($name2, $name1) = ($name1, $name2);\n    }\n\n    my $len1 = length($name1);\n    my $len2 = length($name2);\n\n    my $min = int(0.5 + $len2 / 2);\n    return -1 if $min > $len1;\n\n    my $diff = $len1 - $min;\n    foreach my $i (0 .. $diff) {\n        foreach my $j ($i .. $diff) {\n            if (index($name2, substr($name1, $i, $min + $j - $i)) != -1) {\n                return 0;\n            }\n        }\n    }\n\n    return 1;\n}\n\nsub find_similar_filenames (&@) {\n    my $code = shift;\n\n    my %files;\n    find {\n        wanted => sub {\n            !(-d) && push @{$files{\"key\"}}, # to group files by size, change the \"key\" to '-s _' (unquoted)\n              {\n                name => do { utf8::decode($_); lc(s{\\.\\w+\\z}{}r) },\n                real_name => $File::Find::name,\n              };\n          }\n         } => @_;\n\n    foreach my $files (values %files) {\n\n        next if $#{$files} < 1;\n\n        my %dups;\n        foreach my $i (0 .. $#{$files} - 1) {\n            for (my $j = $i + 1 ; $j <= $#{$files} ; $j++) {\n                if (compare_strings($files->[$i]{name}, $files->[$j]{name}) == 0) {\n                    push @{$dups{$files->[$i]{real_name}}}, ${splice @{$files}, $j--, 1}{real_name};\n                }\n            }\n        }\n\n        while (my ($fparent, $fdups) = each %dups) {\n            $code->(sort $fparent, @{$fdups});\n        }\n    }\n\n    return 1;\n}\n\n{\n    local $, = \"\\n\";\n    find_similar_filenames {\n\n        say @_, \"-\" x 80 if @_;\n\n        foreach my $i (\n                         $opts{f} ? (1 .. $#_)\n                       : $opts{l} ? (0 .. $#_ - 1)\n                       :            ()\n          ) {\n            unlink $_[$i] or warn \"[error]: Can't delete: $!\\n\";\n        }\n    }\n    @dirs;\n}\n"
  },
  {
    "path": "Finders/find_similar_filenames_unidec.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 22 June 2012\n# https://github.com/trizen\n\n# Find files which have exactly or *ALMOST*\n# exactly the same name in a given path.\n\n# Improved version here:\n#   https://github.com/trizen/perl-scripts/blob/master/Finders/fsfn.pl\n\nuse 5.014;\nuse strict;\nuse warnings;\n\nuse File::Find qw(find);\nuse Getopt::Std qw(getopts);\nuse Text::Unidecode qw(unidecode);\n\nmy @dirs = grep { -d } @ARGV;\ndie <<\"HELP\" if !@dirs;\nusage: $0 [options] /my/path [...]\n\nOptions:\n        -f  : keep only the first file\n        -l  : keep only the last file\n\nHELP\n\nmy %opts;\nif (@ARGV) {\n    getopts(\"fl\", \\%opts);\n}\n\nsub compare_strings ($$) {\n    my ($name1, $name2) = @_;\n\n    return 0 if $name1 eq $name2;\n\n    if (length($name1) > length($name2)) {\n        ($name2, $name1) = ($name1, $name2);\n    }\n\n    my $len1 = length($name1);\n    my $len2 = length($name2);\n\n    my $min = int(0.5 + $len2 / 2);\n    return -1 if $min > $len1;\n\n    my $diff = $len1 - $min;\n    foreach my $i (0 .. $diff) {\n        foreach my $j ($i .. $diff) {\n            if (index($name2, substr($name1, $i, $min + $j - $i)) != -1) {\n                return 0;\n            }\n        }\n    }\n\n    return 1;\n}\n\nsub find_duplicated_files (&@) {\n    my $code = shift;\n\n    my %files;\n    find {\n        wanted => sub {\n            lstat;\n            -f _ && (not -l _) && push @{$files{\"key\"}}, # to group files by size, change the \"key\" to '-s _' (unquoted)\n              {\n                name => do { utf8::decode($_); lc(unidecode($_) =~ s{\\.\\w+\\z}{}r) },\n                real_name => $File::Find::name,\n              };\n          }\n         } => @_;\n\n    foreach my $files (values %files) {\n\n        next if $#{$files} < 1;\n\n        my %dups;\n        foreach my $i (0 .. $#{$files} - 1) {\n            for (my $j = $i + 1 ; $j <= $#{$files} ; $j++) {\n                if (compare_strings($files->[$i]{name}, $files->[$j]{name}) == 0) {\n                    push @{$dups{$files->[$i]{real_name}}}, ${splice @{$files}, $j--, 1}{real_name};\n                }\n            }\n        }\n\n        while (my ($fparent, $fdups) = each %dups) {\n            $code->(sort $fparent, @{$fdups});\n        }\n    }\n\n    return 1;\n}\n\n{\n    local $, = \"\\n\";\n    find_duplicated_files {\n\n        say @_, \"-\" x 80 if @_;\n\n        foreach my $i (\n                         $opts{f} ? (1 .. $#_)\n                       : $opts{l} ? (0 .. $#_ - 1)\n                       :            ()\n          ) {\n            unlink $_[$i] or warn \"[error]: Can't delete: $!\\n\";\n        }\n    }\n    @dirs;\n}\n"
  },
  {
    "path": "Finders/fsf.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 23 July 2015\n# https://github.com/trizen\n\n# Find files which have almost the same content (at least, mathematically).\n\n#\n## WARNING! For strict duplicates, use the 'fdf' script:\n#   https://github.com/trizen/perl-scripts/blob/master/Finders/fdf\n#\n\nuse 5.014;\nuse strict;\nuse warnings;\n\nuse Math::BigInt (try => 'GMP');\n\nuse File::Find qw(find);\nuse Getopt::Long qw(GetOptions);\n\nsub help {\n    my ($code) = @_;\n\n    print <<\"HELP\";\nusage: $0 [options] /my/path [...]\n\nOptions:\n    -w  --whitespaces! : remove whitespaces (default: false)\n    -u  --unique!      : don't include a file in more groups (default: false)\n    -h  --help         : print this message and exit\n\nExample:\n    $0 -w ~/Documents\n\nHELP\n\n    exit($code // 0);\n}\n\nmy $strip_spaces = 0;    # bool\nmy $unique       = 0;    # bool\n\nGetOptions(\n           'w|whitespaces!' => \\$strip_spaces,\n           'u|unique!'      => \\$unique,\n           'h|help'         => \\&help,\n          )\n  or die(\"Error in command line arguments\");\n\nsub hash ($) {\n    my ($str) = @_;\n\n    $strip_spaces\n      and $str =~ s/\\s+//g;\n\n    state $ten = Math::BigInt->new(10);\n\n    my $hash1 = Math::BigInt->new(0);\n    my $pow   = Math::BigInt->new(1);\n\n    state $chars = {};\n    my @chars = map { $chars->{$_} //= Math::BigInt->new($_) } unpack(\"C*\", $str);\n\n    foreach my $char (@chars) {\n        $hash1->badd($pow->copy->bmul($char));\n        $pow->bmul($ten);\n    }\n\n    return $hash1;\n}\n\nsub hash_file ($) {\n    my ($file) = @_;\n    open my $fh, '<:raw', $file;\n    hash(\n         do { local $/; <$fh> }\n        );\n}\n\nsub alike_hashes ($$) {\n    my ($h1, $h2) = @_;\n\n    my $pow = abs($h1->copy->blog(10) - $h2->copy->blog(10));\n\n    my $ratio = ($h2 > $h1 ? ($h2 / $h1) : ($h1 / $h2));\n    my $limit = 10**$pow;\n\n    $ratio == $limit;\n}\n\nsub find_similar_files (&@) {\n    my $code = shift;\n\n    my @files;\n    find {\n        wanted => sub {\n            (-f)\n              && push @files,\n              {\n                hash => hash_file($File::Find::name),\n                name => $File::Find::name,\n              };\n        }\n    } => @_;\n\n    my %dups;\n    foreach my $i (0 .. $#files - 1) {\n        for (my $j = $i + 1 ; $j <= $#files ; $j++) {\n            if (alike_hashes($files[$i]{hash}, $files[$j]{hash})) {\n                push @{$dups{$files[$i]{name}}},\n                  (\n                    $unique\n                    ? ${splice @files, $j--, 1}{name}\n                    : $files[$j]{name}\n                  );\n            }\n        }\n    }\n\n    while (my ($fparent, $fdups) = each %dups) {\n        $code->(sort $fparent, @{$fdups});\n    }\n\n    return 1;\n}\n\n{\n    @ARGV || help(1);\n    local $, = \"\\n\";\n    find_similar_files {\n        say @_, \"-\" x 80 if @_;\n    }\n    @ARGV;\n}\n"
  },
  {
    "path": "Finders/fsfn.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 22 June 2013\n# Improved: 18 October 2014\n# Latest edit on: 18 October 2015\n# Website: https://github.com/trizen\n\n# Find files which have exactly or *ALMOST* exactly\n# the same name in a given path (+Levenshtein distance).\n\n# Review:\n#    https://trizenx.blogspot.com/2013/06/finding-similar-file-names.html\n\n# To move files into another directory, please see:\n#    https://github.com/trizen/perl-scripts/blob/master/File%20Workers/file-mover.pl\n\nuse 5.014;\nuse strict;\nuse warnings;\n\nuse experimental qw(refaliasing);\n\nuse File::Find     qw(find);\nuse List::Util     qw(first min max);\nuse Encode         qw(decode_utf8);\nuse Getopt::Long   qw(GetOptions :config no_ignore_case);\nuse File::Basename qw(basename);\n\nsub help {\n    my ($code) = @_;\n\n    print <<\"HELP\";\nusage: $0 [options] /my/path [...]\n\nOptions:\n        -f  --first!         : keep only the first file from each group\n        -l  --last!          : keep only the last file from each group\n        -g  --groups=[s]     : group individually files which contain these words\n        -G  --nogroups=[s]   : group together files which contain these words\n        -c  --contains=[s]   : ignore files which doesn't contain these words\n        -C  --nocontains=[s] : ignore files which contain these words\n        -i  --insensitive    : make all words case-insensitive\n        -s  --size!          : group files by size (default: off)\n        -S  --sort=s         : sort files by: 'name' or 'size'\n        -p  --percentage=f   : mark the files as similar based on this percent\n        -r  --round-up!      : round up the percentage (default: off)\n        -L  --levenshtein!   : use the Levenshtein distance algorithm\n        -J  --jaro!          : use the Jaro distance algorithm\n        -u  --unidecode!     : normalize Unicode characters to ASCII equivalents\n\nUsage example:\n    $0 --percentage=75 ~/Music\n\nNOTE:\n    The values for -c, -C, -g and -G are regular expressions.\n    Each of the above options can be specified more than once.\n\nWARNING:\n    Options '-f' and '-l' will, permanently, delete your files!\nHELP\n\n    exit($code);\n}\n\nmy @groups;\nmy @no_groups;\n\nmy @contains;\nmy @no_contains;\n\nmy $first         = 0;    # bool\nmy $last          = 0;    # bool\nmy $round_up      = 0;    # bool\nmy $group_by_size = 0;    # bool\nmy $unidecode     = 0;    # bool\nmy $insensitive   = 0;    # bool\nmy $levenshtein   = 0;    # bool\nmy $jaro_distance = 0;    # bool\nmy $percentage;           # float\n\nmy $sort_by = undef;\n\nGetOptions(\n           'f|first!'       => \\$first,\n           'l|last!'        => \\$last,\n           'g|groups=s'     => \\@groups,\n           'G|nogroups=s'   => \\@no_groups,\n           'c|contains=s'   => \\@contains,\n           'C|nocontains=s' => \\@no_contains,\n           'r|round-up!'    => \\$round_up,\n           'i|insensitive!' => \\$insensitive,\n           'p|percentage=f' => \\$percentage,\n           'L|levenshtein!' => \\$levenshtein,\n           'u|unidecode!'   => \\$unidecode,\n           'J|jaro!'        => \\$jaro_distance,\n           's|size!'        => \\$group_by_size,\n           'S|sort=s'       => \\$sort_by,\n           'h|help'         => sub { help(0) },\n          )\n  or die(\"Error in command line arguments\");\n\n@groups      = map { $insensitive ? qr/$_/i : qr/$_/ } (@groups, '.');\n@no_groups   = map { $insensitive ? qr/$_/i : qr/$_/ } @no_groups;\n@contains    = map { $insensitive ? qr/$_/i : qr/$_/ } @contains;\n@no_contains = map { $insensitive ? qr/$_/i : qr/$_/ } @no_contains;\n\n# Determine what algorithm to use for comparison\nmy $algorithm = $levenshtein ? \\&lev_cmp : $jaro_distance ? \\&jaro_cmp : \\&index_cmp;\n\n# Default percentage\n$percentage //= $jaro_distance ? 70 : 50;\n\nsub index_cmp ($$) {\n    my ($name1, $name2) = @_;\n\n    return 0 if $name1 eq $name2;\n\n    my ($len1, $len2) = (length($name1), length($name2));\n    if ($len1 > $len2) {\n        ($name2, $len2, $name1, $len1) = ($name1, $len1, $name2, $len2);\n    }\n\n    my $min =\n      $round_up\n      ? int($percentage / 100 + $len2 * $percentage / 100)\n      : int($len2 * $percentage / 100);\n\n    return -1 if $min > $len1;\n\n    my $diff = $len1 - $min;\n    foreach my $i (0 .. $diff) {\n        foreach my $j ($i .. $diff) {\n            if (index($name2, substr($name1, $i, $min + $j - $i)) != -1) {\n                return 0;\n            }\n        }\n    }\n\n    return -1;\n}\n\n# Levenshtein's distance function (optimized for speed)\nsub lev_cmp ($$) {\n    my ($s, $t) = @_;\n\n    my $len1 = @$s;\n    my $len2 = @$t;\n\n    my ($min, $max) = $len1 < $len2 ? ($len1, $len2) : ($len2, $len1);\n\n    my $diff =\n      $round_up\n      ? int($percentage / 100 + $max * (100 - $percentage) / 100)\n      : int($max * (100 - $percentage) / 100);\n\n    return -1 if ($max - $min) > $diff;\n\n    my @d = ([0 .. $len2], map { [$_] } 1 .. $len1);\n    foreach my $i (1 .. $len1) {\n        foreach my $j (1 .. $len2) {\n            $d[$i][$j] =\n                $$s[$i - 1] eq $$t[$j - 1]\n              ? $d[$i - 1][$j - 1]\n              : min($d[$i - 1][$j], $d[$i][$j - 1], $d[$i - 1][$j - 1]) + 1;\n        }\n    }\n\n    ($d[-1][-1] // $min) <= $diff ? 0 : -1;\n}\n\nsub jaro_cmp($$) {\n    my ($s, $t) = @_;\n\n    my $s_len = @{$s};\n    my $t_len = @{$t};\n\n    ($s, $s_len, $t, $t_len) = ($t, $t_len, $s, $s_len)\n      if $s_len > $t_len;\n\n    $s_len || return -1;\n\n    my $diff =\n      $round_up\n      ? int($percentage / 100 + $t_len * (100 - $percentage) / 100)\n      : int($t_len * (100 - $percentage) / 100);\n\n    return -1 if ($t_len - $s_len) > $diff;\n\n    my $match_distance = int(max($s_len, $t_len) / 2) - 1;\n\n    my @s_matches;\n    my @t_matches;\n\n    \\my @s = $s;\n    \\my @t = $t;\n\n    my $matches = 0;\n    foreach my $i (0 .. $#s) {\n\n        my $start = max(0, $i - $match_distance);\n        my $end   = min($i + $match_distance + 1, $t_len);\n\n        foreach my $j ($start .. $end - 1) {\n            $t_matches[$j] and next;\n            $s[$i] eq $t[$j] or next;\n            $s_matches[$i] = 1;\n            $t_matches[$j] = 1;\n            $matches++;\n            last;\n        }\n    }\n\n    return -1 if $matches == 0;\n\n    my $k              = 0;\n    my $transpositions = 0;\n\n    foreach my $i (0 .. $#s) {\n        $s_matches[$i] or next;\n        while (not $t_matches[$k]) { ++$k }\n        $s[$i] eq $t[$k] or ++$transpositions;\n        ++$k;\n    }\n\n    (($matches / $s_len) + ($matches / $t_len) + (($matches - $transpositions / 2) / $matches)) / 3 * 100 >= $percentage\n      ? 0\n      : -1;\n}\n\nsub normalize_filename {\n    my $str = shift;\n\n    $str = decode_utf8($str);\n\n    if ($unidecode) {\n        require Text::Unidecode;\n        $str = Text::Unidecode::unidecode($str);\n    }\n\n    join(' ', split(' ', lc($str =~ s{\\.\\w{1,5}\\z}{}r =~ s/[^\\pN\\pL]+/ /gr)));\n}\n\nsub sort_files {\n    my (@files) = @_;\n\n    my %seen;\n    @files = grep { !$seen{$_}++ } @files;\n\n    if (defined($sort_by)) {\n        if ($sort_by =~ /size/i) {\n            @files = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [$_, -s $_] } @files;\n        }\n        elsif ($sort_by =~ /name/i) {\n            @files = map { $_->[0] } sort { $a->[1] cmp $b->[1] } map { [$_, lc(basename($_))] } @files;\n        }\n    }\n    else {\n        @files = sort @files;\n    }\n\n    return @files;\n}\n\nsub find_similar_filenames (&@) {\n    my $code = shift;\n\n    my %files;\n    find {\n        wanted => sub {\n\n            if (@contains) {\n                defined(first { $File::Find::name =~ $_ } @contains) || return;\n            }\n            if (@no_contains) {\n                defined(first { $File::Find::name =~ $_ } @no_contains) && return;\n            }\n\n            if (-f) {\n                push @{$files{$group_by_size ? (-s _) : 'key'}}, {\n                    name => do {\n                        my $str = normalize_filename($_);\n                        ($levenshtein || $jaro_distance) ? [$str =~ /\\X/g] : $str;\n                    },\n                    real_name => $File::Find::name,\n                };\n            }\n        }\n    } => @_;\n\n    foreach my $files (values %files) {\n\n        next if $#{$files} < 1;\n\n        my %dups;\n        my @files;\n        foreach my $i (0 .. $#{$files} - 1) {\n            for (my $j = $i + 1 ; $j <= $#{$files} ; $j++) {\n\n                if (defined(my $word1 = first { $files->[$i]{real_name} =~ $_ } @groups)) {\n                    if (defined(my $word2 = first { $files->[$j]{real_name} =~ $_ } @groups)) {\n                        next if $word1 ne $word2;\n                    }\n                }\n\n                if ($algorithm->($files->[$i]{name}, $files->[$j]{name}) == 0) {\n                    if (    defined(first { $files->[$i]{real_name} =~ $_ } @no_groups)\n                        and defined(first { $files->[$j]{real_name} =~ $_ } @no_groups)) {\n                        push @files, $files->[$i]{real_name}, ${splice @{$files}, $j--, 1}{real_name};\n                    }\n                    else {\n                        push @{$dups{$files->[$i]{real_name}}}, ${splice @{$files}, $j--, 1}{real_name};\n                    }\n                }\n            }\n        }\n\n        while (my ($fparent, $fdups) = each %dups) {\n            $code->(sort_files($fparent, @{$fdups}));\n        }\n\n        $code->(sort_files(@files));\n    }\n\n    return 1;\n}\n\n{\n    @ARGV || help(1);\n    local $, = \"\\n\";\n    find_similar_filenames {\n\n        say @_, \"-\" x 80 if @_;\n\n        foreach my $i (\n                         $first ? (1 .. $#_)\n                       : $last  ? (0 .. $#_ - 1)\n                       :          ()\n          ) {\n            unlink $_[$i] or warn \"[error]: Can't delete: $!\\n\";\n        }\n    }\n    @ARGV;\n}\n"
  },
  {
    "path": "Finders/human-like_finder.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 20 April 2014\n# Website: https://github.com/trizen\n\n# A smart human-like substring finder\n# Steps:\n#  1. loop from i=1 and count up to int(sqrt(len(text)))\n#  2. loop from pos=(i-1)*len(substr)*2 and add int(len(text)/i) to pos while pos <= len(text)\n#  3. jump to position pos and scan back and forward and stop if the string is found somewhere nearby\n#  4. loop #2 end\n#  5. loop #1 end\n#  6. return -1\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nmy $TOTAL = 0;    # count performance\nsub DEBUG () { 1 }    # verbose mode\n\nsub random_find {\n    my ($text, $substr) = @_;\n\n    my $tlen = length($text);\n    my $slen = length($substr);\n\n    my $tmax = $tlen - $slen;\n    my $smax = int($slen / 2);    # this value influences the performance\n\n    my $counter = 0;\n    my $locate  = sub {\n        my ($pos, $guess) = @_;\n\n        for my $i (0 .. $smax) {\n\n            ++$counter if DEBUG;    # measure performance\n\n            if (    $pos + $i <= $tmax\n                and substr($guess, $i) eq substr($substr, 0, $slen - $i)\n                and substr($text,  $pos + $i,             $slen) eq $substr) {\n                printf(\"RIGHT (i: %d; counter: %d):\\n>  %*s\\n>  %s\\n\", $i, $counter, $i + $slen, $substr, $guess) if DEBUG;\n                $TOTAL += $counter if DEBUG;\n                return $pos + $i;\n            }\n            elsif (    $pos - $i >= 0\n                   and substr($substr, $i) eq substr($guess, 0, $slen - $i)\n                   and substr($text,   $pos - $i,            $slen) eq $substr) {\n                printf(\"LEFT (i: %d; counter: %d):\\n>  %s\\n>  %*s\\n\", $i, $counter, $substr, $i + $slen, $guess) if DEBUG;\n                $TOTAL += $counter if DEBUG;\n                return $pos - $i;\n            }\n        }\n\n        return;\n    };\n\n    foreach my $i (1 .. int(sqrt($tlen))) {\n        my $delta = int($tlen / $i);\n\n        for (my $pos = ($i - 1) * $slen * 2 ; $pos <= $tlen ; $pos += $delta) {\n\n            say \"POS: $pos\" if DEBUG;\n            if ($pos + $slen <= $tlen) {\n                if (defined(my $i = $locate->($pos, substr($text, $pos, $slen)))) {\n                    say \"** FORWARD MATCH!\" if DEBUG;\n                    return $i;\n                }\n            }\n\n            if ($pos >= $slen) {\n                if (defined(my $i = $locate->($pos - $slen, substr($text, $pos - $slen, $slen)))) {\n                    say \"** BACKWARD MATCH!\" if DEBUG;\n                    return $i;\n                }\n            }\n        }\n    }\n\n    return -1;\n}\n\nmy $text = join('', <DATA>);\nmy $split = 30;\n\nforeach my $str (unpack(\"(A$split)*\", $text)) {\n    if (random_find($text, $str) == -1) {\n        die \"Error!\";\n    }\n    say '-' x 80 if DEBUG;\n}\n\nsay \"TOTAL: \", $TOTAL if DEBUG;\n\n__END__\nThe data structure has one node for every prefix of every\nstring in the dictionary. So if (bca) is in the dictionar\nthen there will be nodes for (bca), (bc), (b), and (). If\nis in the dictionary then it is blue node. Otherwise it i\nThere is a black directed \"child\" arc from each node to a\nis found by appending one character. So there is a black\nThere is a blue directed \"suffix\" arc from each node to t\npossible strict suffix of it in the graph. For example, f\nare (aa) and (a) and (). The longest of these that exists\ngraph is (a). So there is a blue arc from (caa) to (a). T\na green \"dictionary suffix\" arc from each node to the nex\nin the dictionary that can be reached by following blue a\nexample, there is a green arc from (bca) to (a) because (\nnode in the dictionary (i.e. a blue node) that is reached\nthe blue arcs to (ca) and then on to (a).\n"
  },
  {
    "path": "Finders/large_file_search.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 28 July 2014\n# https://github.com/trizen\n\n# Search for a list of keywords inside a very large file\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse Fcntl qw(SEEK_CUR);\nuse List::Util qw(max);\nuse Term::ANSIColor qw(colored);\nuse Getopt::Long qw(GetOptions);\n\n# Input file for search\nmy $file = __FILE__;\n\n# Print before and after characters\nmy $before = 5;\nmy $after  = 5;\n\n# Buffer size\nmy $buffer = 1024**2;    # 1 MB\n\nsub usage {\n    my ($code) = @_;\n\n    print <<\"USAGE\";\n\nusage: $0 [options] [keywords]\n\noptions:\n        --file=s        : a very large file\n        --buffer=i      : buffer size (default: $buffer bytes)\n        --before=i      : display this many characters before match (default: $before)\n        --after=i       : display this many characters after match (default: $after)\n\n        --help          : print this message and exit\n\nexample:\n    $0 --file=document.txt \"Foo Bar\"\n\nUSAGE\n\n    exit($code // 0);\n}\n\nGetOptions(\n           'buffer=i' => \\$buffer,\n           'file=s'   => \\$file,\n           'before=i' => \\$before,\n           'after=i'  => \\$after,\n           'help|h'   => sub { usage(0) },\n          );\n\n@ARGV || usage(1);\n\nmy @keys = @ARGV;\nmy $max = max(map { length } @keys);\n\nif ($buffer <= $max) {\n    die \"The buffer value can't be <= than the length of the longest keyword!\\n\";\n}\n\nsysopen(my $fh, $file, 0);\nwhile ((my $size = sysread($fh, (my $chunk), $buffer)) > 0) {\n\n    # Search for a given keyword\n    foreach my $keyword (@keys) {\n        my $idx = -1;\n        while (($idx = index($chunk, $keyword, $idx + 1)) != -1) {\n\n            # Take the sub-string\n            my $len  = length($keyword);\n            my $bar  = '-' x (40 - $len / 2);\n            my $from = $idx > $before ? $idx - $before : 0;\n            my $sstr = substr($chunk, $from, $len + $after + $before);\n\n            # Split the sub-string\n            my $pos = index($sstr, $keyword);\n            my $bef = substr($sstr, 0,    $pos);\n            my $cur = substr($sstr, $pos, $len);\n            my $aft = substr($sstr, $pos + $len);\n\n            # Highlight and print the results\n            say $bar, $keyword, $bar, '-' x ($len % 2);\n            say $bef, colored($cur, 'red'), $aft;\n            say '-' x 80;\n\n            {    # Unpack and print the results as character-values\n                local $, = ' ';\n                say unpack('C*', $bef), colored(join($,, unpack('C*', $cur)), 'red'), unpack('C*', $aft);\n            }\n\n            say '-' x 80;\n        }\n    }\n\n    # Rewind back a little bit because we\n    # might be in the middle of a keyword\n    if ($size == $buffer) {\n        sysseek($fh, sysseek($fh, 0, SEEK_CUR) - $max, 0);\n    }\n}\nclose($fh);\n"
  },
  {
    "path": "Finders/locatepm",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 18 February 2012\n# Edit: 08 August 2012\n# https://github.com/trizen\n\n# Find installed Perl modules matching a regular expression\n\nuse 5.014;\nuse File::Find qw(find);\nuse Getopt::Std qw(getopts);\n\nsub usage {\n    die <<\"HELP\";\nusage: perl $0 [options] 'REGEX'\\n\noptions:\n        -p  : print full path\n        -b  : both: path + name\n        -i  : case insensitive\\n\nexample:\n        perl $0 -b ^File:: ^Term\nHELP\n}\n\nmy %opts;\ngetopts('pbih', \\%opts);\n\n(!@ARGV || $opts{h}) && usage();\n\nsub reduce_dirs {\n    my %substring_count;\n    @substring_count{@_} = ();\n\n    for my $x (@_) {\n        for my $y (@_) {\n            next if $x eq $y;\n            if (index($x, $y) == 0) {\n                $substring_count{$x}++;\n            }\n        }\n    }\n\n    grep { !$substring_count{$_} } keys %substring_count;\n}\n\nmy @dirs;\nfor my $dirname (@INC) {\n    if (-d $dirname) {\n        next if chr ord $dirname eq q{.};\n        $dirname =~ tr{/}{/}s;\n        chop $dirname if substr($dirname, -1) eq '/';\n        push @dirs, $dirname;\n    }\n}\n@dirs = reduce_dirs(@dirs);\n\nmy $inc_re = do {\n    local $\" = q{|};\n    qr{^(?>@{[map { quotemeta(s{/}{::}gr) } @dirs]})::};\n};\n\nforeach my $arg (@ARGV) {\n    my $regex = $opts{i} ? qr{$arg}i : qr{$arg};\n    find {\n        wanted => sub {\n            my $name = $_;\n            say $opts{b} ? \"$name\\n$_\\n\"\n              : $opts{p} ? $_\n              : $name\n              if substr($name, -3, 3, '') eq '.pm'\n              and $name =~ s{/}{::}g\n              and $name =~ s{$inc_re}{}o\n              and $name =~ /$regex/;\n        },\n        no_chdir => 1,\n         } => @dirs;\n}\n"
  },
  {
    "path": "Finders/longest_substring.pl",
    "content": "#!/usr/bin/perl\n\n# Finding the longest repeated substring\n\n# Java code from:\n#   https://stackoverflow.com/questions/10355103/finding-the-longest-repeated-substring\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nno warnings 'recursion';\n\nmy $max_len = 0;\nmy $max_str = \"\";\n\nsub insert_in_suffix_tree {\n    my ($root, $str, $index, $original_suffix, $level) = @_;\n    $level //= 0;\n\n    push @{$root->{indexes}}, $index;\n\n    if ($#{$root->{indexes}} > 0 && $max_len < $level) {\n        $max_len = $level;\n        $max_str = substr($original_suffix, 0, $level);\n    }\n\n    return if ($str eq q{});\n\n    my $child;\n    my $first_char = substr($str, 0, 1);\n    if (not exists $root->{children}{$first_char}) {\n        $child = {};\n        $root->{children}{$first_char} = $child;\n    }\n    else {\n        $child = $root->{children}{$first_char};\n    }\n\n    insert_in_suffix_tree($child, substr($str, 1), $index, $original_suffix, $level + 1);\n}\n\nmy $str = @ARGV ? join('', <>) : \"abracadabra\";\n\nmy %root;\nforeach my $i (0 .. length($str) - 1) {\n    my $s = substr($str, $i);\n    insert_in_suffix_tree(\\%root, $s, $i, $s);\n}\n\nsay \"[$max_len]: $max_str\";\n"
  },
  {
    "path": "Finders/mimefind.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 April 2023\n# Edit: 21 September 2023\n# https://github.com/trizen\n\n# Find files from a given directory (and its subdirectories) that have a specific mimetype.\n\nuse 5.036;\nuse File::Find  qw(find);\nuse Getopt::Std qw(getopts);\n\nsub usage ($exit_code = 0) {\n    print <<\"EOT\";\nusage: $0 [options] [files | dirs]\n\noptions:\n\n    -T       : display only text files\n    -B       : display only binary files\n    -t TYPE  : display files with this mimetype (regex)\n    -n       : display non-matching files\n    -f       : display only files\n    -e       : use `exiftool` to determine the MIME types (slow)\n    -h       : display this message and exit\n\nexamples:\n\n    perl $0 -t video ~/Music              # find video files\n    perl $0 -Bft . ~/Documents            # find binary files\n    perl $0 -fn -t audio ~/Music          # find non-audio files\n    perl $0 -fn -t 'audio|video' ~/Music  # find non audio/video files\n\nEOT\n    exit($exit_code);\n}\n\ngetopts('TBefhnt:', \\my %opts);\n$opts{t} || usage(1);\n$opts{h} && usage(0);\n\nmy $type_re = qr/$opts{t}/i;\n\nsub determine_mime_type ($file) {\n\n    if (-d $file) {\n        return 'inode/directory';\n    }\n\n    if ($opts{e}) {\n        my $res = `exiftool \\Q$file\\E`;\n        $? == 0       or return;\n        defined($res) or return;\n        if ($res =~ m{^MIME\\s+Type\\s*:\\s*(\\S+)}mi) {\n            return $1;\n        }\n        return;\n    }\n\n    require File::MimeInfo::Magic;\n    File::MimeInfo::Magic::mimetype($file);\n}\n\nfind(\n    {\n     wanted => sub {\n\n         if ($opts{f}) {\n             (-f $_) or return;\n         }\n\n         if ($opts{B}) {\n             (-B $_) or return;\n         }\n\n         if ($opts{T}) {\n             (-T $_) or return;\n         }\n\n         my $mimetype = determine_mime_type($_) // return;\n         my $ok       = ($mimetype =~ $type_re);\n\n         $ok = !$ok if $opts{n};\n\n         if ($ok) {\n             say $File::Find::name;\n         }\n     },\n     no_chdir => 1,\n    },\n    @ARGV\n);\n"
  },
  {
    "path": "Finders/model_matching_system.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 12 June 2015\n# Edit: 25 July 2016\n# https://github.com/trizen\n\n#\n## A very fast complex matching system\n#\n\n# It works by creating a nested hash with words stored as paths,\n# then it walks this nested hash from path to path, looking for matches.\n\n# It matches in (case|word order|space|punctuation)-insensitive mode.\n# The results are sorted to match the input keywords as best as possible.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse List::Util qw(all);\n\nsub split_entry {\n    grep { $_ ne '' } split(/\\W+/, lc($_[0]));\n}\n\nsub update_model {\n    my ($model, $entry) = @_;\n\n    foreach my $word (split_entry($entry)) {\n        my $ref = $model;\n        foreach my $char (split(//, $word)) {\n            $ref = $ref->{$char} //= {};\n            push @{$ref->{values}}, \\$entry;\n        }\n    }\n\n    return 1;\n}\n\nsub find {\n    my ($model, $entry) = @_;\n\n    my @tokens = split_entry($entry);\n\n    my (@words, @matches, %analyzed);\n    foreach my $word (@tokens) {\n\n        my $ref = $model;\n        foreach my $char (split(//, $word)) {\n            if (exists $ref->{$char}) {\n                $ref = $ref->{$char};\n            }\n            else {\n                $ref = undef;\n                last;\n            }\n        }\n\n        if (defined $ref and exists $ref->{values}) {\n            push @words, $word;\n            foreach my $match (@{$ref->{values}}) {\n                if (not exists $analyzed{$match}) {\n                    undef $analyzed{$match};\n                    unshift @matches, $$match;\n                }\n            }\n        }\n        else {\n            @matches = ();    # don't include partial matches\n            last;\n        }\n    }\n\n    foreach my $token (@tokens) {\n        @matches = grep { index(lc($_), $token) != -1 } @matches;\n    }\n\n    # Sort and return the matches\n    map    { $_->[0] }\n      sort { $b->[1] <=> $a->[1] }\n      map {\n        my @parts = split_entry($_);\n\n        my $end_w = $#words;\n        my $end_p = $#parts;\n\n        my $min_end = $end_w < $end_p ? $end_w : $end_p;\n\n        my $order_score = 0;\n        for (my $i = 0 ; $i <= $min_end ; ++$i) {\n            my $word = $words[$i];\n\n            for (my $j = $i ; $j <= $end_p ; ++$j) {\n                my $part = $parts[$j];\n\n                my $matched;\n                my $continue = 1;\n                while ($part eq $word) {\n                    $order_score += 1 - 1 / (length($word) + 1)**2;\n                    $matched ||= 1;\n                    $part = $parts[++$j] // do { $continue = 0; last };\n                    $word = $words[++$i] // do { $continue = 0; last };\n                }\n\n                if ($matched) {\n                    $order_score += 1 - 1 / (length($word) + 1)\n                      if ($continue and index($part, $word) == 0);\n                    last;\n                }\n                elsif (index($part, $word) == 0) {\n                    $order_score += length($word) / length($part);\n                    last;\n                }\n            }\n        }\n\n        my $prefix_score = 0;\n        all {\n            ($parts[$_] eq $words[$_])\n              ? do {\n                $prefix_score += 1;\n                1;\n              }\n              : (index($parts[$_], $words[$_]) == 0) ? do {\n                $prefix_score += length($words[$_]) / length($parts[$_]);\n                0;\n              }\n              : 0;\n        }\n        0 .. $min_end;\n\n        ## printf(\"score('@parts', '@words') = %.4g + %.4g = %.4g\\n\",\n        ##        $order_score, $prefix_score, $order_score + $prefix_score);\n\n        [$_, $order_score + $prefix_score]\n      } @matches;\n}\n\n#\n## Usage example\n#\n\nmy %model;\nwhile (<DATA>) {\n    chomp($_);\n    update_model(\\%model, $_);\n}\n\nsub search {\n    my ($str) = @_;\n    say \"* Results for '$str':\";\n    use Data::Dump qw(pp);\n    say pp([find(\\%model, $str)]), \"\\n\";\n}\n\nsearch('I love');\nsearch('love');\nsearch('a love');\nsearch('love a');\nsearch('actually love');\nsearch('Paris love');\nsearch('love Berlin');\n\n__DATA__\nMy First Lover\nA Lot Like Love\nFunny Games (2007)\nCinderella Man (2005)\nPulp Fiction (1994)\nDon't Say a Word (2001)\nSecret Window (2004)\nThe Lookout (2007)\n88 Minutes (2007)\nThe Mothman Prophecies\nLove Actually (2003)\nFrom Paris with Love (2010)\nP.S. I Love You (2007)\n"
  },
  {
    "path": "Finders/path_diff.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 12 October 2017\n# https://github.com/trizen\n\n# Compare two paths file-by-file and display the filenames of (non-)duplicate files.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Cwd qw(abs_path);\nuse File::Find qw(find);\nuse File::Compare qw(compare);\nuse Getopt::Long qw(GetOptions);\nuse File::Spec::Functions qw(catdir catfile catpath splitdir splitpath);\n\nmy $show_duplicates = 0;\n\nsub usage {\n    print <<\"EOT\";\nusage: $0 [options] [dir1] [dir2]\n\noptions:\n    -e --equal : display filenames of duplicate files (default: $show_duplicates)\n\nEOT\n    exit;\n}\n\nGetOptions('e|equal!' => \\$show_duplicates,\n           'h|help'   => \\&usage,)\n  or die(\"Error in command line arguments!\");\n\nmy ($dir1, $dir2) = map { abs_path($_) } grep { -d } @ARGV;\n\nif (not defined($dir1) or not defined($dir2)) {\n    die \"usage: $0 [dir1] [dir2]\\n\";\n}\n\nmy ($dir1_volume, $dir1_path) = splitpath($dir1, 1);\nmy ($dir2_volume, $dir2_path) = splitpath($dir2, 1);\n\nmy @dir1_parts = splitdir($dir1_path);\nmy @dir2_parts = splitdir($dir2_path);\n\nfind {\n    no_chdir => 1,\n    wanted   => sub {\n        (-f $_) || return;\n\n        my $file1 = $_;\n        my (undef, $directory, $file) = splitpath($file1);\n\n        my @parts = splitdir($directory);\n        splice(@parts, 0, scalar(@dir1_parts));\n\n        my $file2 = catpath($dir2_volume, catdir(@dir2_parts, @parts), $file);\n\n        (-f $file2) || return;\n\n        my $are_equal = ((-s $file1) == (-s $file2) and compare($file1, $file2) == 0);\n\n        if ($show_duplicates) {\n            say catfile(@parts, $file) if $are_equal;\n        }\n        else {\n            say catfile(@parts, $file) if !$are_equal;\n        }\n    }\n} => $dir1;\n"
  },
  {
    "path": "Finders/plocate.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 20 April 2012\n# https://github.com/trizen\n\n# Perl locate - a pretty efficient file locater\n\nuse 5.010;\nuse strict;\n\nuse Getopt::Std qw(getopts);\nuse File::Find qw(find);\nuse File::Spec::Functions qw(rel2abs);\n\nmy $DB_FILE = rel2abs('plocate.db');\n\nsub usage {\n    print <<\"HELP\";\nusage: $0 [options] [dirs]\n\noptions:\n        -g  : generate a $DB_FILE file\n        -i  : insensitive match\n        -h  : show this message\n\nexample: $0 -g /my/dir\n         $0 /tmp/(work|shop).doc\nHELP\n    exit 0;\n}\n\n@ARGV or do { warn \"$0: no pattern to search for specified\\n\"; exit 1 };\n\nmy %opt;\ngetopts('gih', \\%opt);\n\n$opt{h} && usage();\n\nif ($opt{g}) {\n    open my $DB_FH, '>', $DB_FILE or die \"$0: Can't open $DB_FILE: $!\";\n    say {$DB_FH} q{<<'__END_OF_THE_DATABASE__';};\n\n    find {\n        no_chdir => 1,\n        wanted   => sub {\n            say {$DB_FH} rel2abs($_);\n        },\n    } => @ARGV ? grep { -d } @ARGV : q{.};\n\n    say {$DB_FH} q{__END_OF_THE_DATABASE__};\n    close $DB_FH;\n\n    exit 0;\n}\n\n-e $DB_FILE or usage();\n\nmy $files = do $DB_FILE;\nstudy $files;\n\nforeach my $re (@ARGV) {\n    $re = $opt{i} ? qr{$re}i : qr{$re};\n    while ($files =~ /^.*?$re.*/gmp) {\n        say ${^MATCH};\n    }\n}\n"
  },
  {
    "path": "Finders/similar_files_levenshtein.pl",
    "content": "\n#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 13 January 2016\n# https://github.com/trizen\n\n# Finds files which have almost the same content, using the Levenshtein distance.\n\n#\n## WARNING! For strict duplicates, use the 'fdf' script:\n#   https://github.com/trizen/perl-scripts/blob/master/Finders/fdf\n#\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Fcntl qw(O_RDONLY);\nuse File::Find qw(find);\nuse Getopt::Long qw(GetOptions);\nuse Text::LevenshteinXS qw(distance);\nuse Number::Bytes::Human qw(parse_bytes);\n\nmy $unique    = 0;\nmy $threshold = 70;\nmy $max_size  = '100KB';\n\nsub help {\n    my ($code) = @_;\n\n    print <<\"HELP\";\nusage: $0 [options] [/dir/a] [/dir/b] [...]\n\noptions:\n    -s  --size=s      : maximum file size (default: $max_size)\n    -u  --unique!     : don't include a file in more groups (default: false)\n    -t  --threshold=f : threshold percentage (default: $threshold)\n\nExample:\n    perl $0 ~/Documents\n\nHELP\n\n    exit($code // 0);\n}\n\nGetOptions(\n           's|size=s'      => \\$max_size,\n           'u|unique!'     => \\$unique,\n           't|threshold=f' => \\$threshold,\n           'h|help'        => \\&help,\n          )\n  or die(\"Error in command line arguments\");\n\n@ARGV || help();\n$max_size = parse_bytes($max_size);\n\nsub look_similar {\n    my ($f1, $f2) = @_;\n\n    sysopen my $fh1, $f1, O_RDONLY or return;\n    sysopen my $fh2, $f2, O_RDONLY or return;\n\n    my $s1 = (-s $f1) || (-s $fh1);\n    my $s2 = (-s $f2) || (-s $fh2);\n\n    my ($min, $max) = $s1 < $s2 ? ($s1, $s2) : ($s2, $s1);\n\n    my $diff = int($max * (100 - $threshold) / 100);\n    ($max - $min) > $diff and return;\n\n    sysread($fh1, (my $c1), $s1) || return;\n    sysread($fh2, (my $c2), $s2) || return;\n\n    distance($c1, $c2) <= $diff;\n}\n\nsub find_similar_files (&@) {\n    my $code = shift;\n\n    my %files;\n    find {\n        no_chdir => 1,\n        wanted   => sub {\n            lstat;\n            (-f _) && (not -l _) && do {\n                my $size = -s _;\n                if ($size <= $max_size) {\n\n                    # TODO: better grouping\n                    push @{$files{int log $size}}, $File::Find::name;\n                }\n            };\n        }\n    } => @_;\n\n    foreach my $key (sort { $a <=> $b } keys %files) {\n\n        next if $#{$files{$key}} < 1;\n        my @files = @{$files{$key}};\n\n        my %dups;\n        foreach my $i (0 .. $#files - 1) {\n            for (my $j = $i + 1 ; $j <= $#files ; $j++) {\n                if (look_similar($files[$i], $files[$j])) {\n                    push @{$dups{$files[$i]}},\n                      (\n                        $unique\n                        ? splice(@files, $j--, 1)\n                        : $files[$j]\n                      );\n                }\n            }\n        }\n\n        while (my ($fparent, $fdups) = each %dups) {\n            $code->(sort $fparent, @{$fdups});\n        }\n    }\n\n    return 1;\n}\n\n{\n    local $, = \"\\n\";\n    find_similar_files {\n        say @_, \"-\" x 80 if @_;\n    }\n    @ARGV;\n}\n"
  },
  {
    "path": "Formatters/ascii_table_csv.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 15 March 2013\n# https://github.com/trizen\n\n# Print a CSV file to standard output as an ASCII table.\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse open IO => ':utf8';\n\nuse Text::CSV qw();\nuse Text::ASCIITable qw();\nuse Getopt::Std qw(getopts);\n\nbinmode(STDOUT, ':utf8');\n\nmy %opt = (\n           s => 0,\n           d => ',',\n          );\n\ngetopts('sw:d:', \\%opt);\n\nmy $csv_file = shift() // die <<\"USAGE\";\nusage: $0 [options] [csv_file]\n\noptions:\n        -s    : allow whitespace in CSV (default: $opt{s})\n        -d <> : separator character (default: '$opt{d}')\n        -w <> : maximum width for table (default: no limit)\n\nexample: $0 -s -d ';' -w 80 file.csv\nUSAGE\n\nmy %esc = (\n           a => \"\\a\",\n           t => \"\\t\",\n           r => \"\\r\",\n           n => \"\\n\",\n           e => \"\\e\",\n           b => \"\\b\",\n           f => \"\\f\",\n          );\n\n$opt{d} =~ s{(?<!\\\\)(?:\\\\\\\\)*\\\\([@{[keys %esc]}])}{$esc{$1}}g;\n\n## Parse the CSV file\nsub parse_file {\n    my ($file) = @_;\n\n    my %record;\n    open my $fh, '<', $file;\n\n    my $csv = Text::CSV->new(\n                             {\n                              binary           => 1,\n                              allow_whitespace => $opt{s},\n                              sep_char         => $opt{d},\n                             }\n                            )\n      or die \"Cannot use CSV: \" . Text::CSV->error_diag();\n\n    my $columns = $csv->getline($fh);\n\n    my $lines = 0;\n    while (my $row = $csv->getline($fh)) {\n        foreach my $i (0 .. $#{$columns}) {\n            push @{$record{$columns->[$i]}}, $row->[$i];\n        }\n        ++$lines;\n    }\n    $csv->eof() or die \"CSV ERROR: \" . $csv->error_diag(), \"\\n\";\n    close $fh;\n\n    return ($columns, \\%record, $lines);\n}\n\n## Create the ASCII table\nsub create_ascii_table {\n    my ($columns, $record, $lines) = @_;\n\n    my $table = Text::ASCIITable->new();\n    $table->setCols(@{$columns});\n\n    if ($opt{w}) {\n        foreach my $column (@{$columns}) {\n            $table->setColWidth($column, $opt{w} / @{$columns});\n        }\n    }\n\n    foreach my $i (0 .. $lines - 1) {\n        $table->addRow(map { $_->[$i] } @{$record}{@{$columns}});\n    }\n\n    return $table;\n}\n\n{\n    local $| = 1;\n    print create_ascii_table(parse_file($csv_file));\n}\n"
  },
  {
    "path": "Formatters/file_columner.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 18 August 2013\n# https://github.com/trizen\n\n# Put two or more files together as columns.\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse List::Util qw(any);\nuse Getopt::Std qw(getopts);\n\nbinmode(\\*STDOUT, ':encoding(UTF-8)');\n\nmy %opt = (s => 25);\ngetopts('s:h', \\%opt);\n\nsub usage {\n    die <<\"USAGE\";\nusage: $0 [options] [files]\n\noptions:\n        -s <i> : number of spaces between columns (default: $opt{s})\n        -h     : print this message and exit\n\nExample: perl $0 -s 40 file1.txt file2.txt > output.txt\nUSAGE\n}\n\nmy @files = grep {\n    -f or warn \"`$_' is not a file!\\n\";\n    -f _;\n} @ARGV;\n\nif ($opt{h} || !@files) {\n    usage();\n}\n\nmy @fhs = map {\n    open my $fh, '<:encoding(UTF-8):crlf', $_;\n    $fh;\n} @files;\n\nwhile (any { !eof($_) } @fhs) {\n    printf \"%-$opt{s}s \" x $#fhs . \"%s\\n\", map {\n        chomp(\n              my $line =\n                eof($_)\n              ? q{}\n              : scalar(<$_>)\n             );\n        $line;\n    } @fhs;\n}\n"
  },
  {
    "path": "Formatters/fstab_beautifier.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 21 March 2014\n# https://trizenx.blogspot.com\n\n# Realign the columns of a space-delimited file (with support for comments and empty lines)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub fstab_beautifier {\n    my ($fh, $code) = @_;\n\n    my @data;\n    while (defined(my $line = <$fh>)) {\n        if ($line =~ /^#/) {    # it's a comment\n            push @data, {comment => $line};\n        }\n        elsif (not $line =~ /\\S/) {    # it's an empty line\n            push @data, {empty => \"\"};\n        }\n        else {                         # hopefully, it's a line with columns\n            push @data, {fields => [split(' ', $line)]};\n        }\n    }\n\n    # Indicate the EOF (this is used to flush the buffer)\n    push @data, {eof => 1};\n\n    # Store the columns and the width of each column\n    my @buffer;\n    my @widths;\n\n    for (my $i = 0 ; $i <= $#data ; $i++) {\n        my $line = $data[$i];\n\n        if (exists $line->{fields}) {    # it's a line with columns\n\n            # Collect the maximum width of each column\n            while (my ($i, $item) = each @{$line->{fields}}) {\n                if ((my $len = length($item)) > ($widths[$i] //= 0)) {\n                    $widths[$i] = $len;\n                }\n            }\n\n            # Store the line in the buffer\n            # and continue looping to the next line\n            push @buffer, $line->{fields};\n            next;\n        }\n        elsif (exists $line->{comment}) {    # it's a comment\n            $code->(unpack(\"A*\", $line->{comment}));\n        }\n\n        if (@buffer) {                       # buffer is not empty\n\n            # Create the format for 'sprintf'\n            my $format = join(\"\\t\", map { \"%-${_}s\" } splice(@widths));\n\n            # For each line of the buffer, format it and send it further\n            while (defined(my $line = shift @buffer)) {\n                $code->(unpack(\"A*\", sprintf($format, @{$line})));\n            }\n        }\n\n        if (exists $line->{empty}) {         # empty line\n            $code->($line->{empty});\n        }\n    }\n}\n\nmy $fh = @ARGV\n  ? do {\n    open my $fh, '<', $ARGV[0]\n      or die \"Can't open file `$ARGV[0]' for reading: $!\";\n    $fh;\n  }\n  : \\*DATA;\n\n# Call the function with a FileHandle and CODE\nfstab_beautifier($fh, sub { say $_[0] });\n\n__END__\n# My system partitions\n/dev/sda7               swap                     swap           defaults                 0   0\n/dev/sda1               /                               ext3            defaults                 1   1\n/dev/sda2               /home                   ext3            defaults                 1   2\n\n# My /mnt partitions\n/dev/sr0                 /mnt/dvd_sr0    auto           noauto,user,ro  0   0\n/dev/sr1         /mnt/dvd_sr1     auto             noauto,user,ro  0   0\n/dev/fd0                 /mnt/floppy      auto          rw,noauto,user,sync      0   0\n/dev/sdd4        /mnt/zip         vfat             rw,noauto,user,sync   0   0\n/dev/sde1               /mnt/usb          auto             rw,noauto,user,sync   0   0\n\n# My /home/vtel57/ partitions\n/dev/sda8        /home/vtel57/vtel57_archives   ext2     defaults        0   2\n/dev/sdc1        /home/vtel57/vtel57_backups    ext2     defaults        0   2\n/dev/sdc7        /home/vtel57/vtel57_common     vfat     rw,gid=users,uid=vtel57         0   0\n\n# My /dev partitions\ndevpts             /dev/pts              devpts   gid=5,mode=620   0   0\nproc                     /proc                  proc            defaults                 0   0\ntmpfs                   /dev/shm                 tmpfs     defaults              0   0\n"
  },
  {
    "path": "Formatters/js_beautify",
    "content": "#!/usr/bin/perl\n\nuse strict;\nuse warnings;\nuse File::Slurper qw(read_text);\nuse JavaScript::Beautifier qw(js_beautify);\n\n@ARGV && -f $ARGV[0] or die \"usage: $0 <js_file>\\n\";\n\nprint js_beautify(\n                  scalar read_text(shift) => {\n                                              indent_size      => 1,\n                                              indent_character => \"\\t\",\n                                             }\n                 );\n"
  },
  {
    "path": "Formatters/reformat_literal_perl_strings.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 12 November 2017\n# https://github.com/trizen\n\n# Reformat the literal quoted strings in a Perl source code, using Perl::Tokenizer and Data::Dump.\n\n# Example:\n#   'foo姓bar' -> \"foo\\x{59D3}bar\"\n#   '\\'foo\\''  -> \"'foo'\"\n\n# The literal quoted strings (quoted as: q{...}, qq{...}, '...' or \"...\") will be reformatted as \"...\".\n\n# Strings which (potentially) include variable interpolations, are ignored.\n\n# The input source code must be UTF-8 encoded.\n\nuse utf8;\nuse 5.018;\nuse warnings;\n\nuse open IO => ':encoding(UTF-8)', ':std';\n\nuse Data::Dump qw(pp);\nuse Perl::Tokenizer qw(perl_tokens);\n\n# usage: perl script.pl < source.pl\nmy $code = join('', <>);\n\nperl_tokens {\n    my ($name, $i, $j) = @_;\n\n    if (   $name eq 'single_quoted_string'\n        or $name eq 'double_quoted_string'\n        or $name eq 'qq_string'\n        or $name eq 'q_string') {\n\n        my $str = substr($code, $i, $j - $i);\n\n        my $eval_code = join(\n                             ';',\n                             'my $str = qq{' . quotemeta($str) . '}',    # quoted string\n                             'die if $str =~ tr/@$//',                   # skip strings with interpolation\n                             '$str = eval $str',                         # evaluate string\n                             'die if $@',                                # check the status of eval()\n                             '$str',                                     # string content\n                            );\n\n        my $raw_str = eval($eval_code);\n\n        if (defined($raw_str) and !$@) {\n            print scalar pp($raw_str);\n            return;\n        }\n    }\n\n    print substr($code, $i, $j - $i);\n} $code;\n"
  },
  {
    "path": "Formatters/replace_html_links.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 07 December 2017\n# https://github.com/trizen\n\n# Replace URLs inside an HTML file with a given URL.\n\nuse strict;\nuse warnings;\n\nuse open IO => ':utf8';    # use UTF-8 I/O encoding\n\nuse HTML::TreeBuilder;\nuse File::Path qw(make_path);\nuse File::Basename qw(basename);\nuse File::Spec::Functions qw(catfile);\n\n# Directory where to write processed HTML files\nmy $output_dir = 'Processed HTML files';\n\n# The URL used in replacing the other URLs inside the HTML files\nmy $url;\n\n#$url = 'http://example.net';           # predefined URL\n$url //= shift(@ARGV);                  # or URL specified in the first command-line argument\n\nif (not defined($url)) {\n    die \"usage: $0 [url] [HTML files]\\n\";\n}\n\nif (not -d $output_dir) {\n    make_path($output_dir)\n      or die \"Can't create directory `$output_dir': $!\";\n}\n\nforeach my $file (grep { -f } @ARGV) {\n\n    # Open the input HTML file for reading\n    open my $in_fh, '<', $file\n      or do {\n        warn \"Can't open file `$file' for reading: $!\";\n        next;\n      };\n\n    # Create a new HTML::TreeBuilder object\n    my $tree = HTML::TreeBuilder->new;\n\n    # Parse the HTML content\n    $tree->parse_file($in_fh);\n\n    # Traverse the HTML tree and replace URLs\n    $tree->traverse(\n        [\n         sub {\n             my ($elem) = @_;\n\n             if (    ref($elem) eq 'HTML::Element'\n                 and $elem->tag eq 'a'\n                 and defined($elem->attr('href'))\n             ) {\n                 $elem->attr('href', $url);\n             }\n\n             return HTML::Element::OK;\n         },\n        ]\n    );\n\n    # The output HTML filename\n    my $output_file = catfile($output_dir, basename($file));\n\n    # Create the new HTML content\n    my $new_html = $tree->as_HTML;\n\n    # Open the output HTML file for writing\n    open my $out_fh, '>', $output_file or do {\n        warn \"Can't open file `$output_file' for writing: $!\";\n        next;\n    };\n\n    # Write the new HTML content\n    print $out_fh $new_html, \"\\n\";\n\n    # Close the output file-handle\n    close $out_fh;\n}\n"
  },
  {
    "path": "Formatters/sort_perl_subroutines.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 12 April 2024\n# https://github.com/trizen\n\n# Sort the subroutines inside a Perl script, using alphabetical order.\n# Additionally, subroutines that are used by other subroutines, are defined earlier.\n\nuse 5.036;\nuse Perl::Tokenizer qw(perl_tokens);\n\nbinmode(STDOUT, ':utf8');\n\nmy $perl_script = $ARGV[0] // die \"usage: $0 [perl_script.pl]\\n\";\n\nmy $perl_code = do {\n    open my $fh, '<:utf8', $perl_script\n      or die \"Cannot open file <<$perl_script>> for reading: $!\";\n    local $/;\n    <$fh>;\n};\n\nmy %subs;\nmy $header     = '';\nmy $sub_header = '';\n\nmy $header_state     = 1;\nmy $sub_header_state = 0;\nmy $sub_state        = 0;\n\nmy $prev_token   = '';\nmy $prev_token_2 = '';\nmy $extract_name = 0;\nmy $sub_name     = '';\nmy $sub_content  = '';\nmy %calls;\n\nmy $curly_bracket_count = 0;\n\nperl_tokens {\n    my ($token, $pos_beg, $pos_end) = @_;\n\n    my $value = substr($perl_code, $pos_beg, $pos_end - $pos_beg);\n\n    if (\n            $token eq 'keyword'\n        and $value eq 'sub'\n        and (\n             $prev_token eq 'vertical_space'\n             or (    $prev_token eq 'horizontal_space'\n                 and $prev_token_2 eq 'vertical_space')\n            )\n      ) {\n        $header_state     = 0;\n        $sub_header_state = 0;\n        $sub_state        = 1;\n        $sub_content .= 'sub';\n        $extract_name = 1;\n    }\n    elsif ($header_state) {\n        $header .= $value;\n    }\n    elsif ($sub_header_state) {\n        $sub_header .= $value;\n    }\n    elsif ($sub_state) {\n\n        if ($extract_name and $token eq 'sub_name') {\n            $sub_name     = $value;\n            $extract_name = 0;\n        }\n\n        $sub_content .= $value;\n\n        if ($token eq 'bare_word') {\n            ++$calls{$value};\n        }\n\n        if ($token eq 'curly_bracket_open') {\n            ++$curly_bracket_count;\n        }\n        elsif ($token eq 'curly_bracket_close') {\n            --$curly_bracket_count;\n\n            if ($curly_bracket_count == 0) {\n                if ($sub_name eq '') {\n                    $header .= $sub_content;\n                }\n                else {\n                    push @{$subs{$sub_name}},\n                      {\n                        code  => $sub_header . $sub_content,\n                        calls => [sort keys %calls],\n                      };\n                }\n                $sub_header_state = 1;\n                $sub_state        = 0;\n                $sub_content      = '';\n                $sub_header       = '';\n                undef %calls;\n            }\n        }\n\n    }\n\n    ($prev_token_2, $prev_token) = ($prev_token, $token);\n} $perl_code;\n\nsub order_subroutines (@keys) {\n\n    my @subs;\n    foreach my $key (@keys) {\n\n        exists($subs{$key}) or next;\n        my $entry = delete $subs{$key};\n\n        foreach my $sub (@$entry) {\n            my @calls = grep { exists($subs{$_}) and $_ ne $key } @{$sub->{calls}};\n            push(@subs, order_subroutines(@calls)) if @calls;\n            push @subs, $sub->{code};\n        }\n    }\n\n    return @subs;\n}\n\nmy @keys         = map { $_->[1] } sort { $a->[0] cmp $b->[0] } map { [CORE::fc($_) =~ s{^_}{\\xff}r, $_] } keys %subs;\nmy @subs_content = order_subroutines(@keys);\n\n@subs_content = map { unpack('A*', s{^\\s+}{}r) } @subs_content;\n\nprint $header;\nprint join(\"\\n\\n\", @subs_content);\nprint $sub_header . $sub_content;\n"
  },
  {
    "path": "Formatters/word_columner.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 29 August 2012\n# Edit: 18 January 2015\n# Website: https://github.com/trizen\n\n# Put two or more lines together as columns. (with unicode char width support)\n\nuse strict;\nuse warnings;\nuse open IO => ':encoding(UTF-8)', ':std';\n\nuse Getopt::Std qw(getopts);\n\nmy %opt = (\n           c => 2,\n           s => 25,\n           l => 0,\n           r => 0,\n           u => 0,\n          );\n\ngetopts('c:s:l:ruh', \\%opt);\n\nsub usage {\n    die <<\"USAGE\";\nusage: $0 [options] [files]\n\noptions:\n        -c <i> : number of columns (default: $opt{c})\n        -s <i> : number of spaces between words (default: $opt{s})\n        -l <i> : number of leading spaces (default: $opt{l})\n        -u     : use the unicode char width feature\n        -r     : reverse columns\n\nExample: perl $0 -l 3 -s 40 file.txt > output.txt\nUSAGE\n}\n\nusage() if $opt{h} or not @ARGV;\n\nforeach my $file (@ARGV) {\n    open my $fh, '<', $file\n      or do { warn \"$0: Can't open file '$file' for read: $!\\n\"; next };\n\n    my @lines;\n    while (<$fh>) {\n\n        chomp;\n        push @lines, $_;\n\n        if ($. % $opt{c} == 0 || eof $fh and @lines) {\n            my @cols = $opt{r} ? reverse splice @lines : splice @lines;\n\n            my $format = ' ' x $opt{l};\n            if ($opt{u}) {\n                require Text::CharWidth;\n                foreach my $i (0 .. $#cols - 1) {\n                    my $diff = abs(Text::CharWidth::mbswidth($cols[$i]) - length($cols[$i]));\n                    $format .= \"%-\" . ($opt{s} - $diff) . 's';\n                }\n            }\n            else {\n                $format = \"%-$opt{s}s \" x $#cols;\n            }\n            $format .= \"%s\\n\";\n\n            printf $format, @cols;\n        }\n    }\n}\n"
  },
  {
    "path": "GD/AND_sierpinski_triangle.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 20 January 2017\n# https://github.com/trizen\n\n# Generation of the Sierpinski triangle,\n# by plotting the values of the function\n#\n#   f(n) = n AND n^2\n#\n\n# See also:\n#   https://oeis.org/A213541\n#   https://en.wikipedia.org/wiki/Sierpinski_triangle\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager;\n\nmy $size   = 1300;\nmy $factor = 100;\nmy $red    = Imager::Color->new('#ff0000');\n\nmy $img = Imager->new(xsize => $size,\n                      ysize => $size);\n\nforeach my $n (1 .. $size * $factor) {\n    $img->setpixel(\n                   x     => $n / $factor,\n                   y     => $size - ($n & ($n * $n)) / $factor,\n                   color => $red\n                  );\n}\n\n$img->write(file => 'sierpinski_triangle.png');\n"
  },
  {
    "path": "GD/LSystem/LSystem.pm",
    "content": "#!/usr/bin/perl\n\n# Written by jreed@itis.com, adapted by John Cristy.\n# Later adopted and improved by Daniel \"Trizen\" Șuteu.\n\n# Defined rules:\n#   +     Turn clockwise\n#   -     Turn counter-clockwise\n#   :     Mirror\n#   [     Begin branch\n#   ]     End branch\n\n# Any upper case letter draws a line.\n# Any lower case letter is a no-op.\n\npackage LSystem {\n\n    use 5.010;\n    use strict;\n    use warnings;\n\n    use lib qw(.);\n    use Turtle;\n    use Image::Magick;\n    use Math::Trig qw(deg2rad);\n\n    sub new {\n        my ($class, %opt) = @_;\n\n        my %state = (\n                     theta => deg2rad($opt{angle} // 90),\n                     scale => $opt{scale} // 1,\n                     xoff  => $opt{xoff}  // 0,\n                     yoff  => $opt{yoff}  // 0,\n                     len   => $opt{len}   // 5,\n                     color => $opt{color} // 'black',\n                     turtle => Turtle->new($opt{width} // 1000, $opt{height} // 1000, deg2rad($opt{turn} // 0), 1),\n                    );\n\n        bless \\%state, $class;\n    }\n\n    sub translate {\n        my ($self, $letter) = @_;\n\n        my %table = (\n                     '+' => sub { $self->{turtle}->turn($self->{theta}); },                        # Turn clockwise\n                     '-' => sub { $self->{turtle}->turn(-$self->{theta}); },                       # Turn counter-clockwise\n                     ':' => sub { $self->{turtle}->mirror(); },                                    # Mirror\n                     '[' => sub { push(@{$self->{statestack}}, [$self->{turtle}->state()]); },     # Begin branch\n                     ']' => sub { $self->{turtle}->setstate(@{pop(@{$self->{statestack}})}); },    # End branch\n                    );\n\n        if (exists $table{$letter}) {\n            $table{$letter}->();\n        }\n        elsif ($letter =~ /^[[:upper:]]\\z/) {\n            $self->{turtle}->forward($self->{len}, $self);\n        }\n    }\n\n    sub turtle {\n        my ($self) = @_;\n        $self->{turtle};\n    }\n\n    sub execute {\n        my ($self, $string, $repetitions, $filename, %rules) = @_;\n\n        for (1 .. $repetitions) {\n            $string =~ s{(.)}{$rules{$1} // $1}eg;\n        }\n\n        foreach my $command (split(//, $string)) {\n            $self->translate($command);\n        }\n        $self->{turtle}->save_as($filename);\n    }\n}\n\n1;\n"
  },
  {
    "path": "GD/LSystem/Turtle.pm",
    "content": "package Turtle {\n\n    use 5.010;\n    use strict;\n    use warnings;\n\n    # Written by jreed@itis.com, adapted by John Cristy.\n    # Later adopted and improved by Daniel \"Trizen\" Șuteu.\n\n    sub new {\n        my $class = shift;\n\n        my %opt;\n        @opt{qw(x y theta mirror)} = @_;\n\n        # Create the main image\n        my $im = Image::Magick->new(size => $opt{x} . 'x' . $opt{y});\n        $im->ReadImage('canvas:white');\n\n        $opt{im} = $im;\n        bless \\%opt, $class;\n    }\n\n    sub forward {\n        my ($self, $r, $opt) = @_;\n        my ($newx, $newy) = ($self->{x} + $r * sin($self->{theta}), $self->{y} + $r * -cos($self->{theta}));\n\n        $self->draw(\n                    primitive => 'line',\n                    points    => join(' ',\n                                   $self->{x} * $opt->{scale} + $opt->{xoff},\n                                   $self->{y} * $opt->{scale} + $opt->{yoff},\n                                   $newx * $opt->{scale} + $opt->{xoff},\n                                   $newy * $opt->{scale} + $opt->{yoff},\n                                  ),\n                    stroke      => $opt->{color},\n                    strokewidth => 1\n                   );\n\n        ($self->{x}, $self->{y}) = ($newx, $newy);    # change the old coords\n    }\n\n    sub draw {\n        my ($self, %opt) = @_;\n        $self->{im}->Draw(%opt);\n    }\n\n    sub composite {\n        my ($self, %opt) = @_;\n        $self->{im}->Composite(%opt);\n    }\n\n    sub save_as {\n        my ($self, $filename) = @_;\n        $self->{im}->Write($filename);\n    }\n\n    sub turn {\n        my ($self, $dtheta) = @_;\n        $self->{theta} += $dtheta * $self->{mirror};\n    }\n\n    sub state {\n        my ($self) = @_;\n        @{$self}{qw(x y theta mirror)};\n    }\n\n    sub setstate {\n        my $self = shift;\n        @{$self}{qw(x y theta mirror)} = @_;\n    }\n\n    sub mirror {\n        my ($self) = @_;\n        $self->{mirror} *= -1;\n    }\n\n}\n\n1;\n"
  },
  {
    "path": "GD/LSystem/honeycomb.pl",
    "content": "#!/usr/bin/perl\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse lib qw(.);\nuse LSystem;\n\nmy %rules = (\n             A => '-A-B+B+B+B+',\n             B => '-A+B+A+B+A+B+A-',\n            );\n\nmy $lsys = LSystem->new(\n    width  => 1000,\n    height => 1000,\n\n    scale => 1,\n    xoff  => -500,\n    yoff  => -400,\n\n    len   => 20,\n    angle => 60,\n    color => 'orange',\n                       );\n\n$lsys->execute('A', 6, \"honeycomb.png\", %rules);\n"
  },
  {
    "path": "GD/LSystem/honeycomb_2.pl",
    "content": "#!/usr/bin/perl\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse lib qw(.);\nuse LSystem;\n\nmy %rules = (\n             F => '+F-F-F-F-F-F-F-F-F+',    # or: '+F-F-F-F-F-F-F+'\n            );\n\nmy $lsys = LSystem->new(\n    width  => 1200,\n    height => 1000,\n\n    scale => 1,\n    xoff  => -600,\n    yoff  => -180,\n\n    len   => 20,\n    angle => 60,\n    color => 'orange',\n                       );\n\n$lsys->execute('F', 5, \"honeycomb_2.png\", %rules);\n"
  },
  {
    "path": "GD/LSystem/plant.pl",
    "content": "#!/usr/bin/perl\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse lib qw(.);\nuse LSystem;\n\nmy %rules = (S => 'SS+[+S-S-S]-[-S+S+S]');\n\nmy $lsys = LSystem->new(\n    width  => 1000,\n    height => 1000,\n    xoff   => -600,\n\n    len   => 8,\n    angle => 25,\n    color => 'dark green',\n                       );\n\n$lsys->execute('S', 5, \"plant.png\", %rules);\n"
  },
  {
    "path": "GD/LSystem/plant_2.pl",
    "content": "#!/usr/bin/perl\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse lib qw(.);\nuse LSystem;\n\nmy %rules = (\n             S => 'T-[[S]+S]+T[+TS]-S',\n             T => 'TT',                   # or: 'T[S]T'\n            );\n\nmy $lsys = LSystem->new(\n    width  => 1000,\n    height => 1000,\n\n    scale => 0.7,\n    xoff  => -200,\n    yoff  => 300,\n\n    len   => 8,\n    angle => 25,\n    color => 'dark green',\n                       );\n\n$lsys->execute('S', 6, \"plant_2.png\", %rules);\n"
  },
  {
    "path": "GD/LSystem/plant_3.pl",
    "content": "#!/usr/bin/perl\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse lib qw(.);\nuse LSystem;\n\nmy %rules = (F => 'FF-[-F+F-F]+[+F-F]');\n\nmy $lsys = LSystem->new(\n    width  => 1000,\n    height => 1000,\n    xoff   => -350,\n\n    len   => 8,\n    angle => 25,\n    color => 'dark green',\n                       );\n\n$lsys->execute('F', 5, \"plant_3.png\", %rules);\n"
  },
  {
    "path": "GD/LSystem/sierpinski_triangle.pl",
    "content": "#!/usr/bin/perl\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse lib qw(.);\nuse LSystem;\n\nmy %rules = (\n             S => 'S--S--S--T',\n             T => 'TT',\n            );\n\nmy $lsys = LSystem->new(\n    width  => 1000,\n    height => 1000,\n\n    scale => 0.4,\n    xoff  => -280,\n    yoff  => 400,\n\n    len   => 30,\n    angle => 120,\n    turn  => 30,\n    color => 'dark red',\n                       );\n\n$lsys->execute('S--S--S', 7, \"sierpinski_triangle.png\", %rules);\n"
  },
  {
    "path": "GD/LSystem/tree.pl",
    "content": "#!/usr/bin/perl\n\nuse strict;\nuse warnings;\n\nuse lib qw(.);\nuse LSystem;\n\nmy %rules = (\n             a => 'S[---l:a][++++b]',\n             b => 'S[++lb][--c]',\n             c => 'S[-----lb]gS[+:c]',\n             l => '[{S+S+S+S+S+S}]'\n            );\n\nmy $lsys = LSystem->new(\n    width  => 800,\n    height => 800,\n    xoff   => -400,\n\n    len   => 35,\n    angle => 5,\n    color => 'dark green',\n                       );\n\n$lsys->execute('a', 10, \"tree.png\", %rules);\n"
  },
  {
    "path": "GD/XOR_pattern.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 30 October 2017\n# https://github.com/trizen\n\n# Generation of a colored-table of values `n^k (mod m)`, where `n` are the rows and `k` are the columns.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager;\n\nmy $size = 1000;\nmy $red  = Imager::Color->new('#ff0000');\n\nmy $img = Imager->new(xsize => $size,\n                      ysize => $size);\n\nmy $mod = 7;\n\nmy @colors = map {\n    Imager::Color->new(sprintf(\"#%x\", rand(256**3)))\n} 1 .. $mod;\n\nforeach my $n (0 .. $size - 1) {\n    foreach my $k (0 .. $size - 1) {\n        $img->setpixel(x => $k, y => $n, color => $colors[($n ^ $k) % $mod]);\n    }\n}\n\n$img->write(file => 'xor_pattern.png');\n"
  },
  {
    "path": "GD/abstract_map.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 07 June 2015\n# https://github.com/trizen\n\n#\n## Generate a complex shape using basic mathematics.\n#\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse GD::Simple;\n\nmy $max   = 1200000;\nmy $limit = int(sqrt($max)) - 1;\n\n# create a new image\nmy $img = GD::Simple->new($limit * 4, $limit * 2);\n\n# move to right\n$img->moveTo($limit * 3.20, $limit);\n\nmy $j = 1;\nforeach my $i (1 .. $limit) {\n\n    for my $n ($j .. $i**2) {\n        $img->line(2);\n        $img->turn($n**2 / $i);\n        ++$j;\n    }\n\n}\n\nopen my $fh, '>:raw', \"abstract_map.png\";\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/barnsley_fern_fractal.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 20 March 2016\n# Website: https://github.com/trizen\n\n# Perl implementation of the Barnsley fern fractal.\n# See: https://en.wikipedia.org/wiki/Barnsley_fern\n\nuse Imager;\n\nmy $w = 640;\nmy $h = 640;\n\nmy $img = Imager->new(xsize => $w, ysize => $h, channels => 3);\nmy $green = Imager::Color->new('#00FF00');\n\nmy ($x, $y) = (0, 0);\n\nforeach (1 .. 1e5) {\n  my $r = rand(100);\n  ($x, $y) =\n    $r <=  1 ? ( 0.00 * $x - 0.00 * $y,  0.00 * $x + 0.16 * $y + 0.00) :\n    $r <=  8 ? ( 0.20 * $x - 0.26 * $y,  0.23 * $x + 0.22 * $y + 1.60) :\n    $r <= 15 ? (-0.15 * $x + 0.28 * $y,  0.26 * $x + 0.24 * $y + 0.44) :\n               ( 0.85 * $x + 0.04 * $y, -0.04 * $x + 0.85 * $y + 1.60) ;\n  $img->setpixel(x => $w / 2 + $x * 60, y => $y * 60, color => $green);\n}\n\n$img->flip(dir => 'v');\n$img->write(file => 'barnsleyFern.png');\n"
  },
  {
    "path": "GD/binary_triangle.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 16 January 2017\n# https://github.com/trizen\n\n# Draws a balanced binary triangle with n branches on each side.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager;\nuse ntheory qw(:all);\n\nsub line {\n    my ($img, $x, $y, $d, $n) = @_;\n\n    my $x2 = $x + $n * $d;\n    my $y2 = $y + $n * ($d ? 1 : 0);\n\n    $img->line(\n               color => 'red',\n               x1    => $x,\n               x2    => $x2,\n               y1    => $y,\n               y2    => $y2,\n              );\n\n    return if $n <= 1;\n\n    line($img, $x2, $y2, +1, $n >> 1);\n    line($img, $x2, $y2, -1, $n >> 1);\n}\n\nmy $n = 1024;\n\nmy $img = Imager->new(xsize => $n * 2, ysize => $n);\nline($img, $n, 0, 0, $n);\n$img->write(file => 'binary_triangle.png');\n"
  },
  {
    "path": "GD/black_star_turtle.pl",
    "content": "#!/usr/bin/perl\n\nuse integer;\nuse strict;\nuse warnings;\n\nuse GD::Simple;\n\nmy $img = 'GD::Simple'->new(1000, 1000);\n$img->moveTo(700, 500);\n\nmy $nr = 442;\n\nsub t { $img->turn($_[0]) }\nsub l { $img->line($_[0]) }\n\nfor (0 .. $nr) {\n    t 45;\n\n    #l $nr+$_;\n    t -180;\n    l $nr/ 2;\n    t 45;\n    l $nr / 2;\n    t -180;\n    l $nr;\n\n    #t -180;\n    #l $nr / 2;\n    #t 90;\n    #l $nr/2;\n    t -180;\n    l $nr+ $_;\n}\n\nmy $image_name = 'black_star_turtle.png';\n\nopen my $fh, '>', $image_name or die $!;\nprint {$fh} $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/black_yellow_number_triangles.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 25 May 2015\n# https://github.com/trizen\n\n#\n## Generate magic triangles with n gaps between numbers\n#\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse GD::Simple;\nuse File::Spec::Functions qw(catfile);\n\nmy $num_triangles = shift(@ARGV) // 100;    # duration: about 6 minutes\n\nsub generate {\n    my ($n, $j, $data) = @_;\n\n    foreach my $i (1 .. $n) {\n        if ($i % $j == 0) {\n            $data->{$i} = 1;\n        }\n    }\n\n    return $n;\n}\n\nmy $dir = \"Number Triangles\";\nif (not -d $dir) {\n    mkdir($dir)\n      or die \"Can't create dir `$dir': $!\";\n}\n\nforeach my $k (1 .. $num_triangles) {\n\n    my %data;\n    my $max = generate(921600, $k, \\%data);\n    my $limit = int(sqrt($max)) - 1;\n\n    say \"[$k of $num_triangles] Generating...\";\n\n    # create a new image\n    my $img = GD::Simple->new($limit * 2, $limit + 1);\n\n    $img->bgcolor('black');\n    $img->rectangle(0, 0, $limit * 2, $limit + 1);\n\n    my $i = 1;\n    my $j = 1;\n\n    my $black = 0;\n    for my $m (reverse(0 .. $limit)) {\n        $img->moveTo($m, $i - 1);\n\n        for my $n ($j .. $i**2) {\n            if (exists $data{$j}) {\n                $black = 0;\n                $img->fgcolor('yellow');\n            }\n            elsif (not $black) {\n                $black = 1;\n                $img->fgcolor('black');\n            }\n            $img->line(1);\n            ++$j;\n        }\n        ++$i;\n    }\n\n    open my $fh, '>:raw', catfile($dir, sprintf(\"%04d.png\", $k));\n    print $fh $img->png;\n    close $fh;\n}\n"
  },
  {
    "path": "GD/box_pattern.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 24 May 2017\n# https://github.com/trizen\n\n# Generates an interesting pattern.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager;\n\nmy $size = 1000;\nmy $img = Imager->new(xsize => $size, ysize => $size);\n\nforeach my $x (1 .. $size) {\n    foreach my $y (1 .. $size) {\n        if (($x * $y) % (int(sqrt($x)) + int(sqrt($y))) == 0) {\n            $img->setpixel(x => $x - 1, y => $y - 1, color => 'red');\n        }\n    }\n}\n\n$img->write(file => 'box_pattern.png');\n"
  },
  {
    "path": "GD/chaos_game_pentagon.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 29 April 2017\n# https://github.com/trizen\n\n# Chaos game, generating a Sierpinski pentagon.\n\n# See also:\n#   https://www.youtube.com/watch?v=kbKtFN71Lfs\n#   https://www.youtube.com/watch?v=e0JaZuLfZ_0 (starting from 18:03)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager;\n\nmy $width  = 1000;\nmy $height = 1000;\n\nmy @points = (\n    [$width/2,              0],\n    [0,           $height/2.5],\n    [$width,      $height/2.5],\n    [$width/5,        $height],\n    [$width-$width/5, $height],\n);\n\nmy $img = Imager->new(\n                      xsize    => $width,\n                      ysize    => $height,\n                      channels => 3,\n                     );\n\nmy $color = Imager::Color->new('#ff0000');\nmy $r = [$points[rand(@points)], $points[rand(@points)]];\n\nforeach my $i (1 .. 100000) {\n    my $p = $points[rand @points];\n\n    my $h = [\n        sprintf('%.0f',($p->[0] + $r->[0]) / 3) + $width/6,\n        sprintf('%.0f',($p->[1] + $r->[1]) / 3) + $height/5,\n    ];\n\n    $img->setpixel(\n        x     => $h->[0],\n        y     => $h->[1],\n        color => $color,\n    );\n\n    $r = $h;\n}\n\n$img->write(file => 'chaos_game_pentagon.png');\n"
  },
  {
    "path": "GD/chaos_game_tetrahedron.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 25 August 2016\n# https://github.com/trizen\n\n# Chaos game, generating a Sierpinski Tetrahedron.\n# https://en.wikipedia.org/wiki/Chaos_game\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager;\n\nmy $width  = 2000;\nmy $height = 2000;\n\nmy @points = (\n    [int($width/2),                      0],\n    [            0, int($height-$height/4)],\n    [     $width-1, int($height-$height/4)],\n    [int($width/2),              $height-1],\n);\n\nmy $img = Imager->new(\n                      xsize    => $width,\n                      ysize    => $height,\n                      channels => 3,\n                     );\n\nmy $color = Imager::Color->new('#ff0000');\nmy $r = [int(rand($width)), int(rand($height))];\n\nforeach my $i (1 .. 200000) {\n    my $p = $points[rand @points];\n\n    my $h = [\n        int(($p->[0] + $r->[0]) / 2),\n        int(($p->[1] + $r->[1]) / 2),\n    ];\n\n    $img->setpixel(\n        x     => $h->[0],\n        y     => $h->[1],\n        color => $color,\n    );\n\n    $r = $h;\n}\n\n$img->write(file => 'chaos_game_tetrahedron.png');\n"
  },
  {
    "path": "GD/chaos_game_triangle.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 25 August 2016\n# https://github.com/trizen\n\n# Chaos game, generating a Sierpinski triangle, as described by Keith Peters in his presentation.\n# See: https://www.youtube.com/watch?v=e0JaZuLfZ_0 (starting from 18:03)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager;\n\nmy $width  = 1000;\nmy $height = 1000;\n\nmy @points = (\n    [int(rand($width)), 0],\n    [0, int(rand($height))],\n    [int(rand($height)), $height - 1],\n);\n\nmy $img = Imager->new(\n                      xsize    => $width,\n                      ysize    => $height,\n                      channels => 3,\n                     );\n\nmy $color = Imager::Color->new('#ff0000');\nmy $r = [int(rand($width)), int(rand($height))];\n\nforeach my $i (1 .. 100000) {\n    my $p = $points[rand @points];\n\n    my $h = [\n        int(($p->[0] + $r->[0]) / 2),\n        int(($p->[1] + $r->[1]) / 2),\n    ];\n\n    $img->setpixel(\n        x     => $h->[0],\n        y     => $h->[1],\n        color => $color,\n    );\n\n    $r = $h;\n}\n\n$img->write(file => 'chaos_game_triangle.png');\n"
  },
  {
    "path": "GD/circular_prime_triangle.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 02 April 2016\n# https://github.com/trizen\n\n# Generate a triangle with highlighted numbers in the form of: floor(sqrt(prime(i)^2 + i^2))\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager;\nuse List::Util qw(max);\nuse ntheory qw(nth_prime);\n\nmy %data;\n\nsub generate {\n    my ($n) = @_;\n\n    foreach my $i (1 .. $n) {\n        undef $data{int(sqrt(nth_prime($i)**2 + $i * $i))};\n    }\n\n    return 1;\n}\n\ngenerate(100000);\n\nmy $i = 1;\nmy $j = 1;\n\nmy $max   = max(keys %data);\nmy $limit = int(sqrt($max)) - 1;\n\n# Create a new image\nmy $img = Imager->new(xsize => $limit * 2, ysize => $limit + 1);\nmy $red = Imager::Color->new(255, 0, 0);\n\nfor my $m (0 .. $limit) {\n    my $x = $limit - $m;\n    for my $n ($j .. $m**2) {\n        if (exists $data{$j}) {\n            $img->setpixel(x => $x, y => $m, color => $red);\n        }\n        ++$x;\n        ++$j;\n    }\n}\n\n$img->write(file => 'prime_triangle.png');\n"
  },
  {
    "path": "GD/circular_triangle.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 08 June 2015\n# https://github.com/trizen\n\n#\n## Generate a circular triangle based on triangular numbers.\n#\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse GD::Simple;\n\nmy $from = 0;\nmy $step = 1;\n\nmy $max   = 3_000_000;\nmy $limit = int(sqrt($max));\n\n# create a new image\nmy $img = GD::Simple->new($limit * 6, $limit * 6);\n\n# move to right\n$img->moveTo($limit * 2.75, $limit * 1.75);\n\nmy $j = 1;\nforeach my $i (1 .. $limit) {\n\n    for my $n ($j .. $i**2) {\n        $img->line(1);\n        $img->turn(($from + $i) * (($i - $from) / $step + 1) / 2);\n        ++$j;\n    }\n\n    ++$i;\n}\n\nopen my $fh, '>:raw', \"circular_triangle.png\";\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/collatz_triangle.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 21 May 2015\n# https://github.com/trizen\n\n#\n## Generate a triangle with the collatz numbers\n#\n\n# Each pixel is highlighted based on the path frequency;\n# For example: 4 2 1 are the most common number paths and\n# they have the highest frequency and a hotter color (reddish),\n# while a less frequent path is represented by colder color (bluish);\n# in the middle lies the average frequency, represented by a greenish color.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse GD::Simple;\nuse List::Util qw(max sum);\n\nmy %collatz;\n\nsub collatz {\n    my ($n) = @_;\n    while ($n > 1) {\n        if ($n % 2 == 0) {\n            $n /= 2;\n        }\n        else {\n            $n = $n * 3 + 1;\n        }\n        $collatz{$n}++;\n    }\n    return 1;\n}\n\nmy $k = 10000;    # maximum number (duration: about 2 minutes)\n\nfor my $i (1 .. $k) {\n    collatz($i);\n}\n\nmy $i = 1;\nmy $j = 1;\n\nmy $avg = sum(values %collatz) / scalar(keys %collatz);\n\nsay \"Avg: $avg\";\n\nmy $max   = max(keys %collatz);\nmy $limit = int(sqrt($max)) - 1;\n\n# create a new image\nmy $img = GD::Simple->new($limit * 2, $limit + 1);\n\nmy $white = 0;\nfor my $m (reverse(0 .. $limit)) {\n    $img->moveTo($m, $i - 1);\n\n    for my $n ($j .. $i**2) {\n        if (exists $collatz{$j}) {\n\n            my $v     = $collatz{$j};\n            my $ratio = $avg / $v;\n\n            my $red  = 255 - int(255 * $ratio);\n            my $blue = 255 - int(255 / $ratio);\n\n            $red  = 0 if $red < 0;\n            $blue = 0 if $blue < 0;\n\n            $img->fgcolor($red, 255 - (int(($red + $blue) / 2)), $blue);\n            $white = 0;\n        }\n        elsif (not $white) {\n            $white = 1;\n            $img->fgcolor('white');\n        }\n        $img->line(1);\n        ++$j;\n    }\n    ++$i;\n}\n\nopen my $fh, '>:raw', 'collatz.png';\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/color_wheel.pl",
    "content": "#!/usr/bin/perl\n\n# Draw a HSV color wheel.\n\n# Algorithm from:\n#   https://rosettacode.org/wiki/Color_wheel\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager;\nuse Math::GComplex qw(cplx i);\n\nmy ($width, $height) = (300, 300);\nmy $center = cplx($width / 2, $height / 2);\n\nmy $img = Imager->new(xsize => $width,\n                      ysize => $height);\n\nmy $pi = atan2(0, -1);\n\nforeach my $y (0 .. $height - 1) {\n    foreach my $x (0 .. $width - 1) {\n\n        my $vector    = $center - $x - $y * i;\n        my $magnitude = 2 * abs($vector) / $width;\n        my $direction = ($pi + atan2($vector->real, $vector->imag)) / (2 * $pi);\n\n        $img->setpixel(\n            x     => $x,\n            y     => $y,\n            color => {hsv => [360 * $direction, $magnitude, $magnitude < 1 ? 1 : 0]}\n        );\n    }\n}\n\n$img->write(file => 'color_wheel.png');\n"
  },
  {
    "path": "GD/complex_square.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 07 January 2016\n# License: GPLv3\n# Website: https://github.com/trizen\n\n# Illustration of the complex square root function\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager;\nuse Math::AnyNum;\n\nmy $img = Imager->new(xsize => 2000, ysize => 1500);\n\nmy $white = Imager::Color->new('#ffffff');\nmy $black = Imager::Color->new('#000000');\n\n$img->box(filled => 1, color => $black);\n\nfor my $i (1 .. 400) {\n    for my $j (1 .. 400) {\n        my $x = Math::AnyNum->new_c($i, $j)->sqrt;\n        my ($re, $im) = ($x->real->numify, $x->imag->numify);\n        $img->setpixel(x => 300 + int(60 * $re), y => 400 + int(60 * $im), color => $white);\n    }\n}\n\n$img->write(file => 'complex_square.png');\n"
  },
  {
    "path": "GD/congruence_of_squares_triangle.pl",
    "content": "#!/usr/bin/perl\n\n# Highlight integers `k` in a triangle such that `k^2 (mod N)`\n# is a square and leads to a non-trivial factorization of `N`.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse GD::Simple;\nuse ntheory qw(:all);\n\n# Composite integer N for which x^2 == y^2 (mod N)\n# and { gcd(x-y, N), gcd(x+y, N) } are non trivial factors of N.\nmy $N = 43 * 79;\n\nmy $i = 1;\nmy $j = 1;\n\nmy $n     = shift(@ARGV) // 1000000;\nmy $limit = int(sqrt($n)) - 1;\n\nmy $img = GD::Simple->new($limit * 2, $limit + 1);\n$img->bgcolor('black');\n$img->rectangle(0, 0, $limit * 2, $limit + 1);\n\nmy $white = 0;\nfor (my $m = $limit; $m > 0; --$m) {\n\n    $img->moveTo($m, $i - 1);\n\n    for my $n ($j .. $i**2) {\n\n        my $copy = $j;\n        ## $j = ($copy*$copy + 3*$copy + 1);\n\n        my $x = mulmod($j, $j, $N);\n\n        my $root = sqrtint($x);\n        my $r    = gcd($root - $j, $N);\n        my $s    = gcd($root + $j, $N);\n\n        if (is_square($x) and ($j % $N) != $root and (($r > 1 and $r < $N) and ($s > 1 and $s < $N))) {\n            $white = 0;\n            $img->fgcolor('white');\n        }\n        elsif (not $white) {\n            $white = 1;\n            $img->fgcolor('black');\n        }\n        $img->line(1);\n\n        $j = $copy;\n        ++$j;\n    }\n    ++$i;\n}\n\nopen my $fh, '>:raw', 'congruence_of_squares.png';\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/cuboid_turtle.pl",
    "content": "#!/usr/bin/perl\n\nuse strict;\nuse warnings;\n\nuse GD::Simple;\n\nmy $img = 'GD::Simple'->new(2000, 2000);\n$img->moveTo(670, 800);\n\nmy $pi = atan2(1, -'inf');\nmy $nr = $pi * 100;\n\nfor (0 .. 280) {\n    $img->fgcolor('black');\n    $img->turn($nr);\n    $img->line(-$nr);\n    $img->turn(-134.2);\n    $img->line(-$nr);\n    $img->turn($nr);\n    $img->line(-$nr);\n    $img->turn(-134.1);\n    $img->line(-$nr);\n    $img->turn($nr);\n    $img->line(-$nr);\n    $img->turn(-134.2);\n    $img->line(-$nr);\n    $img->turn($nr);\n    $img->line(-$nr);\n    $img->fgcolor('red');\n    $img->turn(134.1);\n    $img->line(-$nr);\n    $img->fgcolor('black');\n    $img->turn(-134.1);\n    $img->line($nr);\n    $img->line(-$nr);\n    $img->turn(-90);\n    $img->line($nr);\n    $img->line(-$nr);\n    $img->turn(90);\n    $img->line(-$nr);\n}\n\nmy $image_name = 'cuboid_turtle.png';\n\nopen my $fh, '>', $image_name or die $!;\nprint {$fh} $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/cuboid_turtle3.pl",
    "content": "#!/usr/bin/perl\n\nuse strict;\nuse warnings;\n\nuse GD::Simple;\n\nmy $img = 'GD::Simple'->new(2500, 2500);\n$img->moveTo(1370, 1580);\n\nmy $nr = 314.9;\n\nfor (0 .. 55) {\n    $img->fgcolor('black');\n    $img->turn($nr);\n    $img->line(-$nr);\n    $img->turn(-$nr);\n    $img->line(-$nr);\n    $img->turn($nr);\n    $img->line($nr);\n    $img->fgcolor('gray');\n    $img->turn(-$nr);\n    $img->line($nr);\n    $img->line($nr);\n    $img->turn($nr);\n    $img->line(-$nr);\n    $img->turn($nr);\n    $img->line(-$nr);\n    $img->fgcolor('red');\n    $img->turn(-$nr);\n    $img->line($nr);\n    $img->line(-$nr);\n    $img->turn($nr);\n    $img->line(-$nr);\n    $img->fgcolor('blue');\n    $img->turn(-$nr);\n    $img->line($nr);\n    $img->turn($nr);\n    $img->line($nr);\n    $img->line($nr);\n    $img->fgcolor('purple');\n    $img->turn(-$nr);\n    $img->line(-$nr);\n    $img->line(-$nr);\n    $img->fgcolor('green');\n    $img->turn($nr);\n    $img->line(-$nr);\n    $img->line(-$nr);\n    $img->line(-$nr);\n    $img->line($nr);\n    $img->fgcolor('gray');\n    $img->turn(-$nr);\n    $img->line($nr);\n    $img->line($nr);\n    $img->line($nr);\n    $img->line($nr);\n    $img->line($nr);\n    $img->line($nr);\n    $img->line($nr);\n    $img->fgcolor('blue');\n    $img->turn(-$nr);\n    $img->line($nr);\n    $img->fgcolor('purple');\n    $img->turn($nr);\n    $img->line(-$nr);\n    $img->fgcolor('red');\n    $img->line(-$nr);\n    $img->line(-$nr);\n}\n\nmy $image_name = 'cuboid_turtle_3.png';\n\nopen my $fh, '>:raw', $image_name or die $!;\nprint {$fh} $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/cuboid_turtle_2.pl",
    "content": "#!/usr/bin/perl\n\nuse strict;\nuse warnings;\n\nuse GD::Simple;\n\nmy $img = 'GD::Simple'->new(3000, 3000);\n$img->moveTo(1660, 1780);\n\nmy $nr = 314.9;\n\nfor (0 .. 44) {\n    $img->fgcolor('black');\n    $img->turn($nr);\n    $img->line(-$nr);\n    $img->turn(-$nr);\n    $img->line(-$nr);\n    $img->turn($nr);\n    $img->line($nr);\n    $img->fgcolor('gray');\n    $img->turn(-$nr);\n    $img->line($nr);\n    $img->line($nr);\n    $img->turn($nr);\n    $img->line(-$nr);\n    $img->turn($nr);\n    $img->line(-$nr);\n    $img->fgcolor('red');\n    $img->turn(-$nr);\n    $img->line($nr);\n    $img->line(-$nr);\n    $img->turn($nr);\n    $img->line(-$nr);\n    $img->fgcolor('blue');\n    $img->turn(-$nr);\n    $img->line($nr);\n    $img->turn($nr);\n    $img->line($nr);\n    $img->line($nr);\n    $img->fgcolor('purple');\n    $img->turn(-$nr);\n    $img->line(-$nr);\n    $img->line(-$nr);\n}\n\nmy $image_name = 'cuboid_turtle_2.png';\n\nopen my $fh, '>', $image_name or die $!;\nprint {$fh} $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/dancing_shapes.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 30 April 2014\n# Website: https://github.com/trizen\n\n# Generate mathematical shapes\n# -- feel free to play with the numbers --\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse GD::Simple;\n\nmy $img = 'GD::Simple'->new(3000, 3000);\n\nsub t($) {\n    $img->turn(shift);\n}\n\nsub l($) {\n    $img->line(shift);\n}\n\nsub c($) {\n    $img->fgcolor(shift);\n}\n\nmy $dirname = \"Dancing shapes\";\n-d $dirname or do {\n    mkdir($dirname)\n      or die \"Can't mkdir '$dirname': $!\";\n};\n\nchdir($dirname)\n  or die \"Can't chdir into '$dirname': $!\";\n\nforeach my $t (1 .. 179) {    # turn from 1 to 179\n    for my $k (5 .. 9) {      # draw this many pictures for each turn\n\n        # Info to STDOUT\n        say \"$t:$k\";\n\n        $img->clear;\n        $img->moveTo(1500, 1500);    # hopefully, at the center of the image\n\n        for my $i (1 .. $t) {        # another interesting set is from 1..$k\n            for my $j (1 .. $k) {\n                $img->fgcolor('green');\n                l(40 * $j);          # the length of a given line (in pixels)\n                $img->fgcolor('blue');\n                l(-40 * ($j / 2));    # if you happen to love textiles, comment this line :)\n                t $t;\n            }\n            $img->fgcolor('red');\n            l 40;\n            ##last;              # to generate only the basic shapes, uncomment this line.\n        }\n\n        my $image_name = sprintf('%03d-%02d.png', $t, $k);\n\n        open my $fh, '>:raw', $image_name or die $!;\n        print {$fh} $img->png;\n        close $fh;\n\n        ## View the image as soon as it is generated\n        #system \"gliv\", $image_name;    # edit this line\n        #$? == 0 or die \"Non-zero exit code of the image viewer: $?\";\n    }\n}\n"
  },
  {
    "path": "GD/divisor_circles.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 14 September 2016\n# Website: https://github.com/trizen\n\n# For each divisor `d` of a number `n`, draw a circle in such a\n# way that the line of the circle passes through both `n` and `d`.\n\nuse 5.014;\nuse strict;\nuse warnings;\n\nuse Imager;\nuse ntheory qw(divisors);\n\nmy $limit = 1000;\nmy $scale = 10;\nmy $red   = Imager::Color->new('#ff0000');\n\nmy $img = Imager->new(xsize => $limit * $scale,\n                      ysize => $limit * $scale,);\n\nsub get_circle {\n    my ($n, $f) = @_;\n    my $r = ($n * $scale - $f * $scale) / 2;\n    ($r, $r + $f * $scale, $limit * $scale / 2);\n}\n\nforeach my $n (1 .. $limit) {\n    foreach my $f (divisors($n)) {\n        my ($r, $x, $y) = get_circle($n, $f);\n        $img->circle(\n                     x      => $x,\n                     y      => $y,\n                     r      => $r,\n                     color  => $red,\n                     filled => 0\n                    );\n    }\n}\n\n$img = $img->rotate(degrees => 90);\n$img->write(file => 'divisor_circles.png');\n"
  },
  {
    "path": "GD/divisor_triangle.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 14 September 2016\n# Website: https://github.com/trizen\n\n# Generates a triangle with non-prime and non-power numbers,\n# each number connected through a line to its divisors.\n\nuse strict;\nuse warnings;\n\nuse Imager;\nuse ntheory qw(is_prime is_power divisors);\n\nuse POSIX qw(ceil);\nuse Memoize qw(memoize);\n\nmemoize('get_point');\n\nmy $limit = 10;\nmy $scale = 1000;\nmy $red   = Imager::Color->new('#ff0000');\n\nmy $img = Imager->new(xsize => 2 * $limit * $scale,\n                      ysize => $limit * $scale);\n\nsub get_point {\n    my ($n) = @_;\n\n    my $row  = ceil(sqrt($n));\n    my $cell = 2 * $row - 1 - $row**2 + $n;\n\n    ($scale * $cell, $scale * $row);\n}\n\nforeach my $n (1 .. $scale) {\n    if (not is_prime($n) and not is_power($n)) {\n\n        my ($x1, $y1) = get_point($n);\n\n        foreach my $divisor (divisors($n)) {\n            my ($x2, $y2) = get_point($divisor);\n            $img->line(\n                       x1    => ($limit * $scale - $y1 - 1) + $x1,\n                       y1    => $y1,\n                       x2    => ($limit * $scale - $y2 - 1) + $x2,\n                       y2    => $y2,\n                       color => $red\n                      );\n        }\n    }\n}\n\n$img->write(file => 'divisor_triangle.png');\n"
  },
  {
    "path": "GD/elementary_cellular_automaton_generalized.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 16 October 2019\n# https://github.com/trizen\n\n# Generalization of the elementary cellular automaton, by using `n` color-states and looking at `k` neighbors left-to-right.\n\n# For example, a value of `n = 3` and `k = 2` uses three different color-states and looks at 2 neighbors to the left and 2 neighbors to the right.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Cellular_automaton\n#   https://en.wikipedia.org/wiki/Elementary_cellular_automaton\n#   https://rosettacode.org/wiki/Elementary_cellular_automaton\n\n# YouTube lectures:\n#   https://www.youtube.com/watch?v=S3tYzCPuVsA\n#   https://www.youtube.com/watch?v=pGGIE5uhPRQ\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Imager;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\nuse Algorithm::Combinatorics qw(variations_with_repetition);\n\nsub automaton ($n, $k, $iter, $rule, $cells = [1]) {\n\n    my %colors = (\n                  0 => 'black',\n                  1 => 'white',\n                  2 => 'red',\n                  3 => 'blue',\n                  4 => 'green',\n                  5 => 'yellow',\n                 );\n\n    say \"Generating $n x $k with rule $rule.\";\n\n    my $size = $iter;\n    my $img  = Imager->new(xsize => $size, ysize => $size >> 1);\n\n    my @states = variations_with_repetition([0 .. $n - 1], 2 * $k + 1);\n    my @digits = reverse todigits($rule, $n);\n\n    my @lookup;\n\n    foreach my $i (0 .. $#states) {\n        $lookup[fromdigits($states[$i], $n)] = $digits[$i] // 0;\n    }\n\n    my @padding         = (0) x (($iter - scalar(@$cells)) >> 1);\n    my @cells           = (@padding, @$cells, @padding);\n    my @neighbors_range = (-$k .. $k);\n\n    my $len = scalar(@cells);\n\n    for my $i (0 .. ($iter >> 1) - 1) {\n\n        foreach my $j (0 .. $#cells) {\n            if ($cells[$j]) {\n                $img->setpixel(\n                               y     => $i,\n                               x     => $j,\n                               color => $colors{$cells[$j]},\n                              );\n            }\n        }\n\n        @cells = @lookup[\n          map {\n              my $i = $_;\n              fromdigits([map { $cells[($i + $_) % $len] } @neighbors_range], $n)\n          } 0 .. $#cells\n        ];\n    }\n\n    return $img;\n}\n\nautomaton(2, 1, 1000, \"30\")->write(file => \"rule_30.png\");\nautomaton(3, 1, 1000, \"3760220742240\")->write(file => \"sierpinski_3x1.png\");\nautomaton(3, 1, 1000, \"2646595889467\")->write(file => \"random_3x1-1.png\");\nautomaton(3, 1, 1000, \"4018294395539\")->write(file => \"random_3x1-2.png\");\nautomaton(3, 1, 1000, \"5432098941\", [2])->write(file => \"random_2x2-3.png\");\nautomaton(2, 2, 1000, \"413000741\")->write(file => \"random_2x2.png\");\n"
  },
  {
    "path": "GD/fact_exp_primorial_growing.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 19 August 2015\n# Website: https://github.com/trizen\n\n# Plot the growing of exponentiation, factorial and primorial.\n\n# blue is n!\n# green is n^n\n# red is n-primorial\n\n# The plot is logarithmic in base e.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager qw();\nuse ntheory qw(nth_prime);\n\nmy $xsize = 250;\nmy $ysize = 600;\n\nmy $img = Imager->new(xsize => $xsize, ysize => $ysize);\n\nmy $white = Imager::Color->new('#ffffff');\nmy $red   = Imager::Color->new('#ff0000');\nmy $blue  = Imager::Color->new('#0000ff');\nmy $green = Imager::Color->new('#00ff00');\n\n$img->box(filled => 1, color => $white);\n\nmy $x = 0;\n\n{\n    use Math::AnyNum qw(:overload);\n\n    my $f = 1;\n    my $p = 1;\n\n    for (my $i = 1 ; $i <= 100 ; ++$i) {\n\n        $f *= $i + 1;\n        $p *= nth_prime($i);\n\n        $img->setpixel(x => $x, y => (abs(log($p) - $ysize))->as_int,     color => $red);\n        $img->setpixel(x => $x, y => (abs(log($f) - $ysize))->as_int,     color => $blue);\n        $img->setpixel(x => $x, y => (abs(log($i**$i) - $ysize))->as_int, color => $green);\n\n        $x++;\n    }\n}\n\n$img->write(file => 'grow.png');\n"
  },
  {
    "path": "GD/factor_circles.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 14 September 2016\n# Website: https://github.com/trizen\n\n# For each factor `f` of a composite number `n`, draw a circle\n# in such a way that the line of the circle passes through both `n` and `f`.\n\nuse 5.014;\nuse strict;\nuse warnings;\n\nuse Imager;\nuse List::Util qw(uniq);\nuse ntheory qw(is_prime factor);\n\nmy $limit = 1000;\nmy $scale = 10;\nmy $red   = Imager::Color->new('#ff0000');\n\nmy $img = Imager->new(xsize => $limit * $scale,\n                      ysize => $limit * $scale,);\n\nsub get_circle {\n    my ($n, $f) = @_;\n    my $r = ($n * $scale - $f * $scale) / 2;\n    ($r, $r + $f * $scale, $limit * $scale / 2);\n}\n\nforeach my $n (1 .. $limit) {\n    if (not is_prime($n)) {\n        foreach my $f (uniq(factor($n))) {\n            my ($r, $x, $y) = get_circle($n, $f);\n            $img->circle(\n                         x      => $x,\n                         y      => $y,\n                         r      => $r,\n                         color  => $red,\n                         filled => 0\n                        );\n        }\n    }\n}\n\n$img = $img->rotate(degrees => 90);\n$img->write(file => 'factor_circles.png');\n"
  },
  {
    "path": "GD/factor_triangle.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 14 September 2016\n# Website: https://github.com/trizen\n\n# Generates a triangle with non-prime and non-power numbers,\n# each number connected through a line to its prime factors.\n\n# The triangles that are forming, are the prime numbers.\n# For example, the first two triangles are 2 and 3 respectively.\n\nuse strict;\nuse warnings;\n\nuse Imager;\nuse ntheory qw(is_prime is_power factor);\n\nuse POSIX qw(ceil);\nuse List::Util qw(uniq);\nuse Memoize qw(memoize);\n\nmemoize('get_point');\n\nmy $limit = 10;\nmy $scale = 1000;\nmy $red   = Imager::Color->new('#ff0000');\n\nmy $img = Imager->new(xsize => 2 * $limit * $scale,\n                      ysize => $limit * $scale);\n\nsub get_point {\n    my ($n) = @_;\n\n    my $row  = ceil(sqrt($n));\n    my $cell = 2 * $row - 1 - $row**2 + $n;\n\n    ($scale * $cell, $scale * $row);\n}\n\nforeach my $n (1 .. $scale) {\n    if (not is_prime($n) and not is_power($n)) {\n\n        my ($x1, $y1) = get_point($n);\n        my @f = uniq(factor($n));\n\n        foreach my $factor (@f) {\n            my ($x2, $y2) = get_point($factor);\n            $img->line(\n                       x1    => ($limit * $scale - $y1 - 1) + $x1,\n                       y1    => $y1,\n                       x2    => ($limit * $scale - $y2 - 1) + $x2,\n                       y2    => $y2,\n                       color => $red\n                      );\n        }\n    }\n}\n\n$img->write(file => 'factor_triangle.png');\n"
  },
  {
    "path": "GD/factorial_turtles.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 20 July 2015\n# Website: https://github.com/trizen\n\n# An image generator based on the following formula: n!/(n-1)!, n!/(n-2)!, ... n!/(n-n)!\n\n# Simplified as:\n#  n!/(n-1)! = n\n#  n!/(n-2)! = n * (n-1)\n#  n!/(n-3)! = n * (n-1) * (n-2)\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse GD::Simple;\n\nuse Math::AnyNum;\nuse File::Spec::Functions qw(catfile);\n\nmy $beg = 3;                      # start point\nmy $end = 30;                     # end point\nmy $dir = 'Factorial turtles';    # where to output the images\n\nif (not -d $dir) {\n    mkdir($dir)\n      or die \"Can't mkdir `$dir': $!\";\n}\n\nforeach my $n ($beg .. $end) {\n\n    {\n        local $| = 1;\n        printf(\"[%3d of %3d]\\r\", $n, $end);\n    }\n\n    my $img = 'GD::Simple'->new(5000, 5000);\n    $img->moveTo(2500, 2500);\n    $img->fgcolor('red');\n\n    my @values;\n    my $p = Math::AnyNum->new(1);\n    foreach my $j (0 .. $n - 1) {\n        $p *= $n - $j;\n        push @values, $p;\n    }\n\n    for my $i (1 .. 100) {\n        foreach my $value (@values) {\n            $img->line($i);\n            $img->turn($value);\n        }\n    }\n\n    my $image_name = catfile($dir, sprintf('%03d.png', $n));\n\n    open my $fh, '>:raw', $image_name or die $!;\n    print {$fh} $img->png;\n    close $fh;\n}\n"
  },
  {
    "path": "GD/factors_of_two_triangle.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 09 August 2016\n# https://github.com/trizen\n\n#\n## Generates a number triangle, highlighting the number of\n## factors of two with a different color for each number n.\n#\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse GD::Simple;\nuse ntheory qw(factor);\nuse List::Util qw(max shuffle);\n\nmy @colors = shuffle(grep { !/black|gradient/ } GD::Simple->color_names);\n\nmy %data;\n\nsub generate {\n    my ($n) = @_;\n\n    foreach my $i (0 .. $n) {\n        $data{$i} = grep { $_ == 2 } factor($i);\n    }\n\n    return 1;\n}\n\ngenerate(1000000);      # takes about 10 seconds\n\nmy $i = 1;\nmy $j = 1;\n\nmy $max   = max(keys %data);\nmy $limit = int(sqrt($max)) - 1;\n\nmy $img = GD::Simple->new($limit * 2, $limit + 1);\n\nfor my $m (reverse(0 .. $limit)) {\n    $img->moveTo($m, $i - 1);\n\n    for my $n ($j .. $i**2) {\n        if ($data{$j} > 0) {\n            $img->fgcolor($colors[$data{$j}]);\n        }\n        else {\n            $img->fgcolor('black');\n        }\n        $img->line(1);\n        ++$j;\n    }\n    ++$i;\n}\n\nopen my $fh, '>:raw', 'factors_of_two.png';\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/farey_turnings_plot.pl",
    "content": "#!/usr/bin/perl\n\n# Plot the turnings in the Farey approximation process.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Farey_sequence\n#   https://en.wikipedia.org/wiki/Stern%E2%80%93Brocot_tree\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse GD::Simple;\nuse Math::AnyNum qw(abs);\nuse experimental qw(signatures);\n\nsub farey_approximation ($r) {\n\n    my ($m, $n) = abs($r)->rat_approx->nude;\n\n    my $enc = '';\n\n    for (; ;) {\n        if ((($m <=> $n) || last) < 0) {\n            $enc .= '0';\n            $n -= $m;\n        }\n        else {\n            $enc .= '1';\n            $m -= $n;\n        }\n    }\n\n    return $enc;\n}\n\nmy $turns = do {\n    local $Math::AnyNum::PREC = 30000;\n    farey_approximation(Math::AnyNum::tau());\n};\n\nsay substr($turns, 0, 50);\n\nmy $width  = 2000;\nmy $height = 2000;\n\nmy $img = 'GD::Simple'->new($width, $height);\n\n$img->moveTo($width / 1.75, $height / 1.25);\n\nmy $angle = 60;\n\nforeach my $t (split(//, $turns)) {\n\n    $t\n      ? $img->turn($angle)\n      : $img->turn(-$angle);\n\n    $img->line(5);\n}\n\nopen my $fh, '>:raw', 'farey_plot.png' or die $!;\nprint {$fh} $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/fgraph.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 02 July 2014\n# Edit: 15 July 2014\n# https://github.com/trizen\n\n# Map a mathematical function on the xOy axis.\n# usage: perl fgraph.pl 'function' 'graph-size' 'from' 'to'\n# usage: perl fgraph.pl '$x**2 + 1'\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nmy $e = exp(1);\nmy $pi = atan2(0, -'inf');\n\nmy $function = @ARGV ? shift @ARGV : ();\n\nmy $f =\n  defined($function)\n  ? (eval(\"sub {my(\\$x) = \\@_; $function}\") // die \"Invalid function '$function': $@\")\n  : sub { my ($x) = @_; $x**2 + 1 };\n\nmy $size = 150;\nmy $range = [-8, 8];\n\nif (@ARGV) {\n    $size = shift @ARGV;\n}\n\nif (@ARGV) {\n    $range->[0] = shift @ARGV;\n}\n\nif (@ARGV) {\n    $range->[1] = shift @ARGV;\n}\n\nif (@ARGV) {\n    die \"Too many arguments! (@ARGV)\";\n}\n\n# Generic creation of a matrix\nsub create_matrix {\n    my ($size, $val) = @_;\n    int($size / 2), [map { [($val) x ($size)] } 0 .. $size - 1];\n}\n\n# Create a matrix\nmy ($i, $matrix) = create_matrix($size, ' ');\n\n# Assign the point inside the matrix\nsub assign {\n    my ($x, $y, $value) = @_;\n\n    $x += $i;\n    $y += $i;\n\n    $matrix->[-$y][$x] = $value;\n}\n\n# Map the function\nforeach my $x ($range->[0] .. $range->[1]) {\n    my $y = eval { $f->($x) };\n\n    if ($@) {\n        warn \"Function f(x)=${\\($function=~s/\\$//rg=~s/\\*\\*/^/rg)} is not defined for x=$x\\n\";\n        next;\n    }\n\n    say \"($x, $y)\";         # this line prints the coordinates\n    assign($x, $y, 'o');    # this line maps the value of (x, f(x)) on the graph\n}\n\n# Init the GD::Simple module\nrequire GD::Simple;\nmy $img = GD::Simple->new($i * 2, $i * 2);\n\nmy $imgFile = 'graph.png';\n\nsub l {\n    $img->line(shift);\n}\n\nsub c {\n    $img->fgcolor(shift);\n}\n\nsub mv {\n    $img->moveTo(@_);\n}\n\nmv(0, 0);\n\n# Create the image from the 2D-matrix\nwhile (my ($k, $row) = each @{$matrix}) {\n    while (my ($l, $col) = each @{$row}) {\n        if ($col eq ' ') {\n            if ($k == $i) {    # the 'x' line\n                c('white');\n                l(1);\n            }\n            elsif ($l == $i) {    # the 'y' line\n                c('white');\n                l(1);\n            }\n            else {                # space\n                c('black');\n                l(1);\n            }\n        }\n        else {                    # everything else\n            c('red');\n            l(1);\n        }\n    }\n    mv(0, $k + 1);\n}\n\n# Create the PNG file\nopen my $fh, '>', $imgFile;\nprint {$fh} $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/fgraph_precision.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 02 July 2014\n# Edit: 15 July 2014\n# https://github.com/trizen\n\n# Map a mathematical function on the xOy axis.\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse GD::Simple qw();\nuse Getopt::Long qw(GetOptions);\n\nmy $e = exp(1);\nmy $pi = atan2(0, -'inf');\n\nmy $size = 150;\nmy $step = 1e-2;\nmy $from = -5;\nmy $to   = abs($from);\n\nmy $v = !1;\nmy $f = sub { my ($x) = @_; $x**2 + 1 };\n\nmy $output_file = 'function_graph.png';\n\nGetOptions(\n    'size|s=f'     => \\$size,\n    'step=f'       => \\$step,\n    'from=f'       => \\$from,\n    'to|t=f'       => \\$to,\n    'verbose|v!'   => \\$v,\n    'output|o=s'   => \\$output_file,\n    'function|f=s' => sub {\n        my (undef, $value) = @_;\n        $f = eval(\"sub {my(\\$x) = \\@_; $value}\") // die \"Invalid function '$value': $@\";\n    },\n  )\n  || die(\"Error in command line arguments\\n\");\n\n# Generic creation of a matrix\nsub create_matrix {\n    my ($size, $val) = @_;\n    int($size / 2), [map { [($val) x ($size)] } 0 .. $size - 1];\n}\n\n# Create a matrix\nmy ($i, $matrix) = create_matrix($size, ' ');\n\n# Assign the point inside the matrix\nsub assign {\n    my ($x, $y, $value) = @_;\n\n    $x += $i;\n    $y += $i;\n\n    $matrix->[-$y][$x] = $value;\n}\n\n# Map the function\nfor (my $x = $from ; $x <= $to ; $x += $step) {\n    my $y = eval { $f->($x) };\n\n    if ($@) {\n        warn \"f($x) is not defined!\\n\";\n        next;\n    }\n\n    $y = sprintf('%.0f', $y);\n    say \"($x, $y)\" if $v;    # this line prints the coordinates\n    assign($x, $y, 'o');     # this line maps the value of (x, f(x)) on the graph\n}\n\n# Init the GD::Simple module\nmy $img = GD::Simple->new($i * 2, $i * 2);\n\nsub l {\n    $img->line(shift);\n}\n\nsub c {\n    $img->fgcolor(shift);\n}\n\nsub mv {\n    $img->moveTo(@_);\n}\n\nmv(0, 0);\n\n# Create the image from the 2D-matrix\nwhile (my ($k, $row) = each @{$matrix}) {\n    while (my ($l, $col) = each @{$row}) {\n        if ($col eq ' ') {\n            if ($k == $i) {    # the 'x' line\n                c('white');\n                l(1);\n            }\n            elsif ($l == $i) {    # the 'y' line\n                c('white');\n                l(1);\n            }\n            else {                # space\n                c('black');\n                l(1);\n            }\n        }\n        else {                    # everything else\n            c('red');\n            l(1);\n        }\n    }\n    mv(0, $k + 1);\n}\n\n# Create the PNG file\nopen my $fh, '>', $output_file or die \"$output_file: $!\";\nprint {$fh} $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/fibonacci_gd.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 18 May 2014\n# https://github.com/trizen\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse GD::Simple;\n\nmy $img = 'GD::Simple'->new(1500, 1000);\n$img->moveTo(250, 530);\n\nsub t($) {\n    $img->turn(shift);\n}\n\nsub l($) {\n    $img->line(shift);\n}\n\nsub c($) {\n    $img->fgcolor(shift);\n}\n\nsub fib {\n    my ($n) = @_;\n    my $res = $n < 2 ? $n : fib($n - 2) + fib($n - 1);\n    l($res * 4);\n    t(90);\n    $res;\n}\n\nfib(14);\n\nmy $image_name = 'fibonacci_turtle.png';\n\nopen my $fh, '>', $image_name or die $!;\nprint {$fh} $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/fibonacci_spirals.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 18 July 2015\n# https://github.com/trizen\n\n#\n## Generate a Fibonacci cluster of spirals.\n#\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse GD::Simple;\n\nmy $img = 'GD::Simple'->new(8000, 8000);\n$img->moveTo(3500, 3500);\n\nsub t($) {\n    $img->turn(shift);\n}\n\nsub l($) {\n    $img->line(shift);\n}\n\nsub c($) {\n    $img->fgcolor(shift);\n}\n\nsub fibonacci(&$) {\n    my ($callback, $n) = @_;\n    my @fib = (1, 1);\n    for (1 .. $n - 2) {\n        $callback->($fib[0]);\n        @fib = ($fib[-1], $fib[-1] + $fib[-2]);\n    }\n    $callback->($_) for @fib;\n}\n\nc 'red';\nfor my $i (1 .. 180) {\n    fibonacci {\n        l $_[0]**(1 / 11);\n        t $i;\n    }\n    $i;\n    t 0;\n}\n\nmy $image_name = 'fibonacci_spirals.png';\n\nopen my $fh, '>:raw', $image_name or die $!;\nprint {$fh} $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/generator_turtle.pl",
    "content": "#!/usr/bin/perl\n\nuse GD::Simple;\n\n$img = 'GD::Simple'->new(1000, 1000);\n$img->moveTo(445, 275);\n\nmy $nr = 124;\n\nsub t { $img->turn($_[0]) }\nsub l { $img->line($_[0]) }\n\nfor (0 .. 125) {\n    l $nr;\n    t 90;\n    l -$nr;\n    l $nr;\n    t -90;\n    l $nr;\n    l $nr/ 2;\n    t 90;\n    l $nr/ 2;\n    t 90;\n    l $nr;\n    t -90;\n    l $nr* 2;\n    t -90;\n    l $nr* 2;\n    t -90;\n    l $nr* 2;\n    t -90;\n    l $nr;\n    t -180;\n    l $nr;\n    t 45;\n    l $nr;\n    t -180;\n    l $nr;\n    t -45;\n    l $nr* 2;\n    t -45;\n    l $nr;\n    t 90;\n    l -$nr;\n    t -45;\n    l -$nr * 2;\n    t -45;\n    l -$nr;\n\n    #last;\n}\n\nmy $image_name = 'turtle_generator.png';\n\nopen my $fh, '>', $image_name or die $!;\nprint {$fh} $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/geometric_shapes.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 02th December 2013\n# Website: https://trizenx.blgospot.com\n\n# This script tries to generate geometric shapes with a consistent internal angle size\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\nuse GD::Simple;\n\nmy $width  = 3000;\nmy $height = 3000;\n\nmy $step      = 1;\nmy $len       = 500;\nmy $sides     = 360;\nmy $max_angle = 160;\n\nmy $dir = 'Geometric shapes';\n\n(-d $dir) || (mkdir($dir));\nchdir($dir);\n\nfor (my $angle = 30 ; $angle <= $max_angle ; $angle += $step) {\n\n    my $p = GD::Simple->new($width, $height);\n\n    $p->fgcolor('blue');\n    $p->moveTo(1500, 1000);\n\n    my %seen;\n    my $text  = '';\n    my $valid = 0;\n\n    foreach my $i (1 .. $sides) {\n        if ($seen{join $;, $p->curPos}++) {\n            $text = sprintf \"%d degrees internal angle with %d sides\", 180 - $angle, $i - 1;\n            $valid = 1;\n            last;\n        }\n\n        $p->turn($angle);\n        $p->line($len);\n    }\n\n    $valid || next;\n\n    say $text;\n\n    # $p->moveTo($width / 2 - length($text) * 3, $height - 100);\n    # $p->string($text);\n\n    open my $fh, '>', sprintf(\"%05d.png\", 180 - $angle);\n    print {$fh} $p->png;\n    close $fh;\n\n    #system \"geeqie\", $img_file;\n    #$? && exit $? << 8;\n}\n"
  },
  {
    "path": "GD/goldbach_conjecture_possibilities.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 29 July 2015\n# Website: https://github.com/trizen\n\n# Plot the number of possibilities of each number for the Goldbach conjecture.\n\n# Example:\n# 16 = {3+13; 5+11}  => 2 possibilities for the number 16\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager qw();\nuse ntheory qw(primes is_prime);\n\nmy $limit = 1e4;\n\nmy $xsize = $limit;\nmy $ysize = int($limit / (1 / 5 * log($limit)**2));    # approximation\n\nmy ($x, $y) = (0, $ysize);\nmy $img = Imager->new(xsize => $xsize, ysize => $ysize);\n\nmy $white = Imager::Color->new('#ffffff');\nmy $gray  = Imager::Color->new('#5f5d5d');\n\n$img->box(filled => 1, color => $white);\n\nmy @primes;\nmy $last_n = 2;\nforeach my $i (3 .. $limit) {\n\n    my $n = 2 * $i;\n    push @primes, @{primes($last_n, $n - 2)};\n    $last_n = $n - 2;\n\n    my %seen;\n    my $count = 0;\n    foreach my $prime (@primes) {\n        exists($seen{$prime}) && last;\n        if (is_prime($n - $prime)) {\n            ++$count;\n            undef $seen{$n - $prime};\n        }\n    }\n\n    foreach my $i (1 .. $count) {\n        $img->setpixel(x => $x, y => $y - $i, color => $gray);\n    }\n\n    $x += 1;\n}\n\n$img->write(file => \"goldbach_possibilities.png\");\n"
  },
  {
    "path": "GD/horsie_art.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 08 June 2015\n# https://github.com/trizen\n\n#\n## Generate a \"horsie\" image based on simple mathematics.\n#\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse GD::Simple;\n\nmy $max   = 3_500_000;\nmy $limit = int(sqrt($max));\n\n# create a new image\nmy $img = GD::Simple->new($limit * 6, $limit * 6);\n\n# move to right\n$img->moveTo($limit * 4, $limit * 4);\n\nmy $j = 1;\nforeach my $i (1 .. $limit) {\n\n    my $t = $i;\n    for my $n ($j .. $i**2) {\n        $img->line(1);\n        $img->turn($t);\n        $t += $i;\n        ++$j;\n    }\n\n    ++$i;\n}\n\nopen my $fh, '>:raw', \"horsie_art.png\";\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/julia_set.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 07 March 2016\n# Edit: 25 January 2018\n# Website: https://github.com/trizen\n\n# See also:\n#   https://en.wikipedia.org/wiki/Julia_set\n#   https://trizenx.blogspot.com/2016/05/julia-set.html\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager;\nuse Math::GComplex qw(cplx);\n\nmy($w, $h, $zoom) = (1000, 1000, 0.7);\n\nmy $img   = Imager->new(xsize => $w, ysize => $h, channels => 3);\nmy $color = Imager::Color->new('#000000');\n\nmy $I = 255;\nmy $L = 2;\nmy $c = cplx(-0.7, 0.27015);\n\nmy ($moveX, $moveY) = (0, 0);\n\nforeach my $x (0 .. $w - 1) {\n    foreach my $y (0 .. $h - 1) {\n\n        my $z = cplx(\n            (2 * $x - $w) / ($w * $zoom) + $moveX,\n            (2 * $y - $h) / ($h * $zoom) + $moveY,\n        );\n\n        my $i = $I;\n        while (abs($z) < $L and --$i) {\n            $z = $z*$z + $c;\n        }\n\n        $color->set(hsv => [$i / $I * 360 - 120, 1, $i / $I]);\n        $img->setpixel(x => $x, y => $y, color => $color);\n    }\n}\n\n$img->write(file => 'julia_set.png');\n"
  },
  {
    "path": "GD/julia_set_complex.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 27 March 2016\n# Website: https://github.com/trizen\n\n# Generate 100 random Julia sets.\n# Formula: f(z) = z^2 + c\n\n# See also: https://en.wikipedia.org/wiki/Julia_set\n#           https://rosettacode.org/wiki/Julia_set\n\nuse strict;\nuse warnings;\n\nuse Imager;\nuse Inline 'C';\n\nfor (1 .. 100) {\n\n    my ($w, $h) = (800, 600);\n\n    my $zoom  = 1;\n    my $moveX = 0;\n    my $moveY = 0;\n\n    my $img = Imager->new(xsize => $w, ysize => $h, channels => 3);\n\n    ##my $maxIter = int(rand(200))+50;\n    my $maxIter = 50;\n\n    ##my ($cx, $cy) = (-rand(1), rand(1));\n    ##my ($cx, $cy) = (1-rand(2), 1-rand(2));         # cool\n    my ($cx, $cy) = (1 - rand(2), rand(1));    # nice\n    ##my ($cx, $cy) = (1 - rand(2), 2 - rand(3));\n    ##my ($cx, $cy) = ((-1)**((1,2)[rand(2)]) * rand(2), (-1)**((1,2)[rand(2)]) * rand(2));\n\n    my $color = Imager::Color->new('#000000');\n\n    foreach my $x (0 .. $w - 1) {\n        foreach my $y (0 .. $h - 1) {\n            my $i = iterate(\n                3/2 * (2*($x+1) - $w) / ($w * $zoom) + $moveX,\n                1/1 * (2*($y+1) - $h) / ($h * $zoom) + $moveY,\n                $cx, $cy, $maxIter\n            );\n            $color->set(hsv => [$i / $maxIter * 360 - 120, 1, $i]);\n            $img->setpixel(x => $x, y => $y, color => $color);\n        }\n    }\n\n    print \"Writing new image...\\n\";\n    $img->write(file => \"i=$maxIter;c=$cx+$cy.png\");\n}\n\n__END__\n__C__\n\n#include <complex.h>\n\nint iterate(double zx, double zy, double cx, double cy, int i) {\n    double complex z = zx + zy * I;\n    double complex c = cx + cy * I;\n    while (cabs(z) < 2 && --i) {\n        z = z*z + c;\n        //z = z * cexp(z) + c;\n        //z = ccosh(z) + c;\n        //z = z * csinh(z) + c;\n        //z = z * ccosh(z) + c;\n        //z = clog(csinh(z)) + c;\n        //z = csqrt(cexp(z) + ccosh(z)) + c;\n    }\n    return i;\n}\n"
  },
  {
    "path": "GD/julia_set_random.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 26 March 2016\n# Website: https://github.com/trizen\n\n# Generate 100 random Julia sets.\n# Formula: f(z) = z^2 + c\n\n# See also: https://en.wikipedia.org/wiki/Julia_set\n#           https://rosettacode.org/wiki/Julia_set\n\nuse strict;\nuse warnings;\n\nuse Imager;\nuse Inline 'C';\n\nfor (1 .. 100) {\n\n    my ($w, $h) = (800, 600);\n\n    my $zoom  = 1;\n    my $moveX = 0;\n    my $moveY = 0;\n\n    my $img = Imager->new(xsize => $w, ysize => $h, channels => 3);\n\n    #my $maxIter = int(rand(200))+50;\n    my $maxIter = 50;\n\n    #my ($cX, $cY) = (-rand(1), rand(1));\n    #my ($cX, $cY) = (1-rand(2), 1-rand(2));        # cool\n    my ($cX, $cY) = (1 - rand(2), rand(1));         # nice\n\n    my $color = Imager::Color->new('#000000');\n\n    foreach my $x (0 .. $w - 1) {\n        foreach my $y (0 .. $h - 1) {\n            my $zx = 3/2 * (2*($x+1) - $w) / ($w * $zoom) + $moveX;\n            my $zy = 1/1 * (2*($y+1) - $h) / ($h * $zoom) + $moveY;\n            my $i  = iterate($zx, $zy, $cX, $cY, $maxIter);\n            $color->set(hsv => [$i / $maxIter * 360, 1, $i]);\n            $img->setpixel(x => $x, y => $y, color => $color);\n        }\n    }\n\n    $img->write(file => \"i=$maxIter;x=$cX;y=$cY.png\");\n}\n\n__END__\n__C__\n\nint iterate(double zx, double zy, double cX, double cY, int i) {\n    double tmp1;\n    double tmp2;\n\n    while(1) {\n        tmp1 = zx*zx;\n        tmp2 = zy*zy;\n\n        if (!((tmp1 + tmp2 < 4) && (--i > 0))) {\n            break;\n        }\n\n        zy = 2 * zx*zy + cY;\n        zx = tmp1 - tmp2 + cX;\n    }\n    return i;\n}\n"
  },
  {
    "path": "GD/julia_set_rperl.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 27 March 2016\n# Website: https://github.com/trizen\n\n# Generate a Julia set, using Will Braswell's \"MathPerl::Fractal::Julia\" RPerl module.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager;\nuse MathPerl::Fractal::Julia;\n\nmy ($w, $h) = (800, 600);\nmy $maxIter = 250;\n\nmy $cx = -0.7;\nmy $cy = 0.27015;\n\nmy $matrix = MathPerl::Fractal::Julia::julia_escape_time(\n    $cx, $cy, $w, $h, $maxIter, -2.5, 1.0, -1.0, 1.0, 0,\n);\n\nmy $img = Imager->new(xsize => $w, ysize => $h, channels => 3);\nmy $color = Imager::Color->new('#000000');\n\nmy $y = 0;\nforeach my $row (@{$matrix}) {\n    my $x = 0;\n    foreach my $pixel (@{$row}) {\n        my $i = $maxIter - $pixel / 255 * $maxIter;\n        $color->set(hsv => [$i / $maxIter * 360, 1, $i]);\n        $img->setpixel(x => $x, y => $y, color => $color);\n        ++$x;\n    }\n    ++$y;\n}\n\n$img->write(file => \"julia_set.png\");\n"
  },
  {
    "path": "GD/koch_snowflakes.pl",
    "content": "#!/usr/bin/perl\n\n# Draw Koch snowflakes as concentric rings, using Math::PlanePath.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Koch_snowflake\n#   https://metacpan.org/pod/Math::PlanePath::KochSnowflakes\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::PlanePath::KochSnowflakes;\nmy $path = Math::PlanePath::KochSnowflakes->new;\n\nuse Imager;\n\nmy $img = Imager->new(xsize => 1000, ysize => 1000);\nmy $red = Imager::Color->new('#ff0000');\n\nforeach my $n (1 .. 100000) {\n    my ($x, $y) = $path->n_to_xy($n);\n    $img->setpixel(x => 500 + $x, y => 500 + $y, color => $red);\n}\n\n$img->write(file => 'Koch_snowflakes.png');\n"
  },
  {
    "path": "GD/langton_s_ant_gd.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# License: GPLv3\n# Date: 15 December 2013\n# Website: https://trizenx.blgospot.com\n\n# Variation of: https://rosettacode.org/wiki/Langton%27s_ant#Perl\n# More info about Langton's ant: https://en.wikipedia.org/wiki/Langton%27s_ant\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse GD::Simple;\n\nmy $width  = 1920;\nmy $height = 1080;\n\nmy $line = 10;     # line length\nmy $size = 100;    # pattern size\n\nmy $turn_left_color  = 'red';\nmy $turn_right_color = 'black';\n\nmy $img_file = 'langton_s_ant.png';\n\nmy $p = GD::Simple->new($width, $height);\n$p->moveTo($width / 2, $height / 2);\n\n# Using screen coordinates - 0,0 in upper-left, +X right, +Y down -\n# these directions (right, up, left, down) are counterclockwise\n# so advance through the array to turn left, retreat to turn right\nmy @dirs = ([1, 0], [0, -1], [-1, 0], [0, 1]);\n\n# we treat any false as white and true as black, so undef is fine for initial all-white grid\nmy @plane;\nfor (0 .. $size - 1) { $plane[$_] = [] }\n\n# start out in approximate middle\nmy ($x, $y) = ($size / 2, $size / 2);\n\n# pointing in a random direction\nmy $dir = int rand @dirs;\n\n# turn in a random direction\n$p->turn(90 * $dir);\n\nmy $move;\nfor ($move = 0 ; $x >= 0 && $x < $size && $y >= 0 && $y < $size ; $move++) {\n\n    # toggle cell's value (white->black or black->white)\n    if ($plane[$x][$y] = 1 - ($plane[$x][$y] ||= 0)) {\n\n        # if it's now true (black), then it was white, so turn right\n        $p->fgcolor($turn_right_color);\n        $p->line($line);\n\n        # for more interesting patterns, try multiplying 90 with $dir\n        $p->turn(90);\n\n        $dir = ($dir - 1) % @dirs;\n    }\n    else {\n\n        # otherwise it was black, so turn left\n        $p->fgcolor($turn_left_color);\n        $p->line($line);\n        $p->turn(-90);\n\n        $dir = ($dir + 1) % @dirs;\n    }\n\n    $x += $dirs[$dir][0];\n    $y += $dirs[$dir][1];\n}\n\nopen my $fh, '>', $img_file or die \"$img_file: $!\";\nprint {$fh} $p->png;\nclose $fh;\n"
  },
  {
    "path": "GD/line_pattern_triangles.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 26 May 2015\n# https://github.com/trizen\n\n#\n## Generate line-pattern triangles\n#\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse GD::Simple;\nuse File::Spec::Functions qw(catfile);\n\nmy $num_triangles = shift(@ARGV) // 15;    # duration: about 1 minute\n\nsub generate {\n    my ($n, $k, $data) = @_;\n\n    my $acc = 1;\n    for (my $i = 1 ; $i <= $n ;) {\n        if ($acc % $k == 0) {\n            foreach my $j (1 .. $acc) {\n                $data->{$i + $j} = 1;\n            }\n        }\n        $i += $acc;\n        $acc++;\n    }\n\n    return $n;\n}\n\nmy $dir = \"Line-pattern Triangles\";\nif (not -d $dir) {\n    mkdir($dir)\n      or die \"Can't create dir `$dir': $!\";\n}\n\nforeach my $k (1 .. $num_triangles) {\n\n    my %data;\n    my $max = generate(921600, $k, \\%data);\n    my $limit = int(sqrt($max)) - 1;\n\n    say \"[$k of $num_triangles] Generating...\";\n\n    # create a new image\n    my $img = GD::Simple->new($limit * 2, $limit + 1);\n\n    $img->bgcolor('black');\n    $img->rectangle(0, 0, $limit * 2, $limit + 1);\n\n    my $i = 1;\n    my $j = 1;\n\n    my $black = 0;\n    for my $m (reverse(0 .. $limit)) {\n        $img->moveTo($m, $i - 1);\n\n        for my $n ($j .. $i**2) {\n            if (exists $data{$j}) {\n                $black = 0;\n                $img->fgcolor('yellow');\n            }\n            elsif (not $black) {\n                $black = 1;\n                $img->fgcolor('black');\n            }\n            $img->line(1);\n            ++$j;\n        }\n        ++$i;\n    }\n\n    open my $fh, '>:raw', catfile($dir, sprintf(\"%04d.png\", $k));\n    print $fh $img->png;\n    close $fh;\n}\n"
  },
  {
    "path": "GD/magic_triangle.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 25 May 2015\n# https://github.com/trizen\n\n#\n## Generate a magic triangle using a simple series of numbers\n#\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse GD::Simple;\nuse List::Util qw(max);\n\nmy %data;\n\nsub generate {\n    my ($n) = @_;\n\n    my $sum = 0;    # will be incremented by 1, 2, 3, ...\n\n    foreach my $i (1 .. $n) {\n        $sum += $i;\n        $data{$sum} = 1;\n    }\n\n    return 1;\n}\n\ngenerate(400);\n\nmy $i = 1;\nmy $j = 1;\n\nmy $max   = max(keys %data);\nmy $limit = int(sqrt($max)) - 1;\n\n# create a new image\nmy $img = GD::Simple->new($limit * 2, $limit + 1);\n\nmy $black = 0;\nfor my $m (reverse(0 .. $limit)) {\n    $img->moveTo($m, $i - 1);\n\n    for my $n ($j .. $i**2) {\n        if (exists $data{$j}) {\n            $black = 0;\n            $img->fgcolor('red');\n        }\n        elsif (not $black) {\n            $black = 1;\n            $img->fgcolor('black');\n        }\n        $img->line(1);\n        ++$j;\n    }\n    ++$i;\n}\n\nopen my $fh, '>:raw', 'magic_triangle.png';\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/mandelbrot_like_set.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 04 October 2017\n# https://github.com/trizen\n\n# Generates a Mandelbrot-like set, using the formula: z = z^(1/c).\n\n# See also:\n#   https://en.wikipedia.org/wiki/Mandelbrot_set\n#   https://trizenx.blogspot.com/2017/01/mandelbrot-set.html\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager;\nuse Inline 'C';\n\nsub mandelbrot_like_set {\n\n    my ($w, $h) = (800, 800);\n\n    my $zoom  = 1;    # the zoom factor\n    my $moveX = 0;    # the amount of shift on the x axis\n    my $moveY = 0;    # the amount of shift on the y axis\n\n    my $L = 100;      # the maximum value of |z|\n    my $I = 30;       # the maximum number of iterations\n\n    my $img   = Imager->new(xsize => $w, ysize => $h);\n    my $color = Imager::Color->new('#000000');\n\n    foreach my $x (1 .. $w) {\n        foreach my $y (1 .. $h) {\n\n            my $i = iterate(\n                (2 * $x - $w) / ($w * $zoom) + $moveX,\n                (2 * $y - $h) / ($h * $zoom) + $moveY,\n                $L, $I,\n            );\n\n            $color->set(hsv => [$i / $I * 360 - 120, 1, $i / $I]);\n            $img->setpixel(x => $x - 1, y => $y - 1, color => $color);\n        }\n    }\n\n    return $img;\n}\n\nmandelbrot_like_set()->write(\n    file => 'mandelbrot_like_set.png'\n);\n\n__END__\n__C__\n\n#include <complex.h>\n\nint iterate(double zx, double zy, int L, int i) {\n    double complex z = zx + zy * I;\n    double complex c = 1/z;\n    while (cabs(z) < L && --i) {\n        z = cpow(z, c);\n    }\n    return i;\n}\n"
  },
  {
    "path": "GD/mandelbrot_like_set_gcomplex.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 25 January 2018\n# https://github.com/trizen\n\n# Generates a Mandelbrot-like set, using the formula: z = z^(1/c).\n\n# See also:\n#   https://en.wikipedia.org/wiki/Mandelbrot_set\n#   https://trizenx.blogspot.com/2017/01/mandelbrot-set.html\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager;\nuse Math::GComplex qw(cplx);\n\nsub mandelbrot_like_set {\n\n    my ($w, $h) = (1000, 1000);\n\n    my $zoom  = 1;    # the zoom factor\n    my $moveX = 0;    # the amount of shift on the x axis\n    my $moveY = 0;    # the amount of shift on the y axis\n\n    my $L = 100;      # the maximum value of |z|\n    my $I = 30;       # the maximum number of iterations\n\n    my $img   = Imager->new(xsize => $w, ysize => $h);\n    my $color = Imager::Color->new('#000000');\n\n    foreach my $x (1 .. $w) {\n        foreach my $y (1 .. $h) {\n\n            my $z = cplx(\n                (2 * $x - $w) / ($w * $zoom) + $moveX,\n                (2 * $y - $h) / ($h * $zoom) + $moveY,\n            );\n\n            my $i = $I;\n            my $c = 1/sqrt($z);\n\n            while (abs($z) < $L && --$i) {\n                $z **= $c;\n            }\n\n            $color->set(hsv => [$i / $I * 360 + 120, 1, $i / $I]);\n            $img->setpixel(x => $x - 1, y => $y - 1, color => $color);\n        }\n    }\n\n    return $img;\n}\n\nmandelbrot_like_set()->write(\n    file => 'mandelbrot_like_set.png'\n);\n"
  },
  {
    "path": "GD/mathematical_butt.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 29 April 2014\n# https://github.com/trizen\n\n# A funny fanny shape. :-)\n\nuse strict;\nuse warnings;\nuse GD::Simple;\n\nmy $img = 'GD::Simple'->new(1000, 1000);\n$img->moveTo(500, 500);\n\nsub t($) {\n    $img->turn(shift);\n}\n\nsub l($) {\n    $img->line(shift);\n}\n\nsub c($) {\n    $img->fgcolor(shift);\n}\n\nfor my $i (1 .. 180) {\n    c 'red';\n    for (1 .. 360) {\n        l 4;    # size\n        t 1;\n    }\n    t 0;\n}\n\nmy $image_name = 'mathematical_butt.png';\n\nopen my $fh, '>:raw', $image_name or die $!;\nprint {$fh} $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/mathematical_shapes.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 30 April 2014\n# Website: https://github.com/trizen\n\n# Generate mathematical shapes\n# -- feel free to play with the numbers --\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse GD::Simple;\n\nmy $img = 'GD::Simple'->new(3000, 3000);\n\nsub t($) {\n    $img->turn(shift);\n}\n\nsub l($) {\n    $img->line(shift);\n}\n\nsub c($) {\n    $img->fgcolor(shift);\n}\n\nmy $dirname = \"Mathematical shapes\";\n-d $dirname or do {\n    mkdir($dirname)\n      or die \"Can't mkdir '$dirname': $!\";\n};\n\nchdir($dirname)\n  or die \"Can't chdir into '$dirname': $!\";\n\nforeach my $t (1 .. 179) {    # turn from 1 to 179\n    for my $k (5 .. 9) {      # draw this many pictures for each turn\n\n        # Info to STDOUT\n        say \"$t:$k\";\n\n        $img->clear;\n        $img->moveTo(1500, 1500);    # hopefully, at the center of the image\n\n        for my $i (1 .. $t) {        # another interesting set is from 1..$k\n            for my $j (1 .. $k) {\n                $img->fgcolor('green');\n                l 40 * $j;           # the length of a given line (in pixels)\n                $img->fgcolor('blue');\n                l -40 * $j;          # if you happen to love textiles, comment this line :)\n                t $t;\n            }\n            $img->fgcolor('red');\n            l 40;\n            ##last;              # to generate only the basic shapes, uncomment this line.\n        }\n\n        my $image_name = sprintf('%03d-%02d.png', $t, $k);\n\n        open my $fh, '>:raw', $image_name or die $!;\n        print {$fh} $img->png;\n        close $fh;\n\n        ## View the image as soon as it is generated\n        #system \"gliv\", $image_name;    # edit this line\n        #$? == 0 or die \"Non-zero exit code of the image viewer: $?\";\n    }\n}\n"
  },
  {
    "path": "GD/mirror_shells.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 30 April 2014\n# Website: https://github.com/trizen\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse GD::Simple;\n\nmy $img = 'GD::Simple'->new(1000, 600);\n$img->moveTo(220, 240);    # hopefully, at the center of the image\n\nsub t($) {\n    $img->turn(shift);\n}\n\nsub l($) {\n    $img->line(shift);\n}\n\nsub c($) {\n    $img->fgcolor(shift);\n}\n\nmy $loop = 50;\nt 260;\n\n# From inside-out\nfor my $j (1 .. $loop) {\n    l $j;\n    t $loop- $j + 1;\n}\n\nt 180;\n\n# From outside-in\nfor my $j (1 .. $loop) {\n    l $loop- $j + 1;\n    t $j;\n}\n\nmy $image_name = \"mirror_shells.png\";\n\nopen my $fh, '>', $image_name or die $!;\nprint {$fh} $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/moebius_walking_line.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 13 November 2016\n# Website: https://github.com/trizen\n\n# Draw a line using the values of the Möbius function: μ(n)\n\n# The rules are the following:\n#   when μ(n) = -1, the angle is changed to -45 degrees\n#   when μ(n) = +1, the angle is changed to +45 degrees\n#   when μ(n) =  0, the angle is changed to   0 degrees\n\n# In all three cases, a pixel is recorded for each value of μ(n).\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse GD::Simple;\nuse ntheory qw(moebius);\n\nmy $width  = 1000;\nmy $height = 100;\n\nmy $img = GD::Simple->new($width, $height);\n\n$img->moveTo(0, $height / 2);\n\nforeach my $u (moebius(1, $width)) {\n    if ($u == 1) {\n        $img->angle(45);\n    }\n    elsif ($u == -1) {\n        $img->angle(-45);\n    }\n    else {\n        $img->angle(0);\n    }\n    $img->line(1);\n}\n\nopen my $fh, '>:raw', 'moebius_walking_like.png';\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/number_triangles.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 25 May 2015\n# https://github.com/trizen\n\n#\n## Generate magic triangles with n gaps between numbers\n#\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse GD::Simple;\nuse File::Spec::Functions qw(catfile);\n\nmy $num_triangles = shift(@ARGV) // 30;    # duration: about 2 minutes\n\nsub generate {\n    my ($n, $j, $data) = @_;\n\n    foreach my $i (1 .. $n) {\n        if ($i % $j == 0) {\n            $data->{$i} = 1;\n        }\n    }\n\n    return $n;\n}\n\nmy $dir = \"Blue Number Triangles\";\nif (not -d $dir) {\n    mkdir($dir)\n      or die \"Can't create dir `$dir': $!\";\n}\n\nforeach my $k (1 .. $num_triangles) {\n\n    my %data;\n    my $max = generate(500000, $k, \\%data);\n    my $limit = int(sqrt($max)) - 1;\n\n    say \"[$k of $num_triangles] Generating...\";\n\n    # create a new image\n    my $img = GD::Simple->new($limit * 2, $limit + 1);\n\n    my $i = 1;\n    my $j = 1;\n\n    my $black = 0;\n    for my $m (reverse(0 .. $limit)) {\n        $img->moveTo($m, $i - 1);\n\n        for my $n ($j .. $i**2) {\n            if (exists $data{$j}) {\n                $black = 0;\n                $img->fgcolor('blue');\n            }\n            elsif (not $black) {\n                $black = 1;\n                $img->fgcolor('black');\n            }\n            $img->line(1);\n            ++$j;\n        }\n        ++$i;\n    }\n\n    open my $fh, '>:raw', catfile($dir, sprintf(\"%04d.png\", $k));\n    print $fh $img->png;\n    close $fh;\n}\n"
  },
  {
    "path": "GD/numeric_circles.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 27 November 2016\n# https://github.com/trizen\n\n# Generates circle-like shapes for arbitrary numerical values (based on Euler's formula).\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse GD::Simple;\n\nmy ($width, $height) = (1000, 1000);\nmy $img = 'GD::Simple'->new($width, $height);\n\nmy $center = ($width + $height) >> 2;\n$img->moveTo($width >> 1, $height >> 1);\n\nmy $number      = 9;       # draw a representation for this number\nmy $granularity = 3000;    # the amount of granularity / detail\n\nmy $step1 = $number / $granularity;\nmy $step2 = $step1 / $number;\n\nmy $tau = 2 * atan2(0, -'inf');\n\nmy $scale = 300;\nmy $color = $img->colorAllocate(255, 0, 0);\n\nfor (my ($i, $j) = (0, 0) ; $j <= $tau ; $i += $step1, $j += $step2) {\n\n    my ($x1, $y1, $x2, $y2) = (\n        map { $_ * $scale + $center }\n            (cos($i), sin($i), cos($j), sin($j))\n    );\n\n    $img->setPixel(($x1 + $x2) >> 1, ($y1 + $y2) >> 1, $color);\n}\n\nmy $image_name = \"circle_$number.png\";\n\nopen my $fh, '>:raw', $image_name or die \"error: $!\";\nprint {$fh} $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/pascal-fibonacci_triangle.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 25 March 2019\n# https://github.com/trizen\n\n# Generate a visual representation of the Pascal-Fibonacci triangle.\n\n# Definition by Elliott Line, Mar 22 2019:\n#   Consider a version of Pascal's Triangle: a triangular array with a single 1 on row 0,\n#   with numbers below equal to the sum of the two numbers above it if and only if that sum\n#   appears in the Fibonacci sequence. If the sum is not a Fibonacci number, `1` is put in its place.\n\n# OEIS sequence:\n#   https://oeis.org/A307069\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager qw();\nuse ntheory qw(is_square);\nuse experimental qw(signatures);\n\nsub is_fibonacci($n) {\n    my $m = 5 * $n * $n;\n    is_square($m - 4) or is_square($m + 4);\n}\n\nmy $size = 1000;                                          # the size of the triangle\nmy $img  = Imager->new(xsize => $size, ysize => $size);\n\nmy $black = Imager::Color->new('#000000');\nmy $red   = Imager::Color->new('#ff00000');\n\n$img->box(filled => 1, color => $black);\n\nsub pascal_fibonacci {\n    my ($rows) = @_;\n\n    my @row = (1);\n\n    foreach my $n (1 .. $rows - 1) {\n\n        my $i      = 0;\n        my $offset = ($rows - $n) / 2;\n\n        foreach my $elem (@row) {\n            $img->setpixel(\n                           x     => $offset + $i++,\n                           y     => $n,\n                           color => {\n                                     hsv => [$elem == 1 ? 0 : (360 / sqrt($elem)), 1 - 1 / $elem, 1 - 1 / $elem]\n                                    }\n                          );\n        }\n\n        if ($n <= 10) {\n            say \"@row\";\n        }\n\n#<<<\n        @row = (1, (map {\n            my $t = $row[$_] + $row[$_ + 1];\n            is_fibonacci($t) ? $t : 1;\n        } 0 .. $n - 2), 1);\n#>>>\n    }\n}\n\npascal_fibonacci($size);\n\n$img->write(file => \"pascal_fibonacci_triangle.png\");\n"
  },
  {
    "path": "GD/pascal_powers_of_two_triangle.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 06 May 2019\n# https://github.com/trizen\n\n# Generate a visual representation of the Pascal powers of two triangle.\n\n# OEIS sequence:\n#   https://oeis.org/A307433\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager qw();\nuse Math::GMPz;\nuse experimental qw(signatures);\n\nsub is_power_of_two ($n) {\n    (($n) & ($n - 1)) == 0;\n}\n\nmy $two_power = 10;\nmy $size      = 1 << $two_power;\nmy $img       = Imager->new(xsize => $size, ysize => $size);\n\nmy $black = Imager::Color->new('#000000');\nmy $red   = Imager::Color->new('#ff00000');\n\n$img->box(filled => 1, color => $black);\n\nmy $ONE = Math::GMPz->new(1);\n\nsub map_value {\n    my ($value, $in_min, $in_max, $out_min, $out_max) = @_;\n    ((($value - $in_min) * ($out_max - $out_min)) / ($in_max - $in_min)) + $out_min;\n}\n\nsub pascal_powers_of_two {\n    my ($rows) = @_;\n\n    my @row = ($ONE);\n\n    foreach my $n (1 .. $rows) {\n\n        my $i      = 0;\n        my $offset = ($rows - $n) / 2;\n\n        foreach my $elem (@row) {\n\n            my $t = Math::GMPz::Rmpz_sizeinbase($elem, 2);\n            my $hue = ($elem == 1) ? 0 : map_value($t, 0, 1 << ($two_power - 1), 1, 360);\n\n            $img->setpixel(\n                           x     => $offset + $i++,\n                           y     => $n,\n                           color => {\n                                     hsv => [$hue, 1, ($elem == 1) ? 0 : 1]\n                                    }\n                          );\n        }\n\n        if ($n <= 11) {\n            say \"@row\";\n        }\n\n#<<<\n        @row = ($ONE, (map {\n            my $t = $row[$_] + $row[$_ + 1];\n            is_power_of_two($t) ? $t : $ONE;\n        } 0 .. $n - 2), $ONE);\n#>>>\n    }\n}\n\npascal_powers_of_two($size);\n\n$img->write(file => \"pascal_powers_of_two_triangle.png\");\n"
  },
  {
    "path": "GD/pascal_s_triangle_multiples.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 29 November 2015\n# Website: https://github.com/trizen\n\n# Highlight multiples inside the Pascal's triangle.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager qw();\nuse ntheory qw(binomial);\n\nmy $div  = 3;      # highlight multiples of this integer\nmy $size = 243;    # the size of the triangle\n\nmy $img = Imager->new(xsize => $size * 2, ysize => $size);\n\nmy $black = Imager::Color->new('#000000');\nmy $red   = Imager::Color->new('#ff00000');\n\n$img->box(filled => 1, color => $black);\n\nsub pascal {\n    my ($rows) = @_;\n\n    for my $n (1 .. $rows - 1) {\n        my $i = 0;\n        for my $elem (map { binomial(2 * $n, $_) } 0 .. 2 * $n) {\n            if ($elem % $div == 0) {\n                $img->setpixel(x => $rows - $n + $i++, y => $n, color => $black);\n            }\n            else {\n                $img->setpixel(x => $rows - $n + $i++, y => $n, color => $red);\n            }\n        }\n    }\n}\n\npascal($size);\n\n$img->write(file => \"pascal_s_triangle.png\");\n"
  },
  {
    "path": "GD/pascal_special_triangle.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 06 May 2019\n# https://github.com/trizen\n\n# Generate a visual representation of a special Pascal triangle, where all entries satisfy a certain condition.\n# If the sum of the two numbers above in the triangle does not satisfy the condition, then we put a constant value in its place.\n\n# OEIS sequences:\n#   https://oeis.org/A307116\n#   https://oeis.org/A307433\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager qw();\nuse ntheory qw(:all);\nuse Math::AnyNum;\nuse experimental qw(signatures);\n\nmy $VALUE = Math::AnyNum->new(2);    # constant value\n\nmy $size = 1000;\nmy $img  = Imager->new(xsize => $size, ysize => $size);\n\nmy $black = Imager::Color->new('#000000');\nmy $red   = Imager::Color->new('#ff00000');\n\n$img->box(filled => 1, color => $black);\n\nsub isok ($n) {                      # condition\n    kronecker($n - 1, $n) == 1;\n}\n\nsub map_value ($value, $in_min, $in_max, $out_min, $out_max) {\n    ((($value - $in_min) * ($out_max - $out_min)) / ($in_max - $in_min)) + $out_min;\n}\n\nsub special_pascal_triangle ($rows) {\n\n    my @rows;\n    my @row = ($VALUE);\n\n    foreach my $n (1 .. $rows) {\n\n        push @rows, [@row];\n\n        if ($n <= 10) {\n            say join(' ', map { $_->round } @row);\n        }\n\n#<<<\n        @row = ($VALUE, (map {\n            my $t = $row[$_] + $row[$_ + 1];\n            isok($t) ? $t : $VALUE;\n        } 0 .. $n - 2), $VALUE);\n#>>>\n    }\n\n    foreach my $row (@rows) {\n        @$row = map { log($_) } @$row;\n    }\n\n    my $min_value = vecmin(map { @$_ } @rows);\n    my $max_value = vecmax(map { @$_ } @rows);\n\n    say \"Min: $min_value\";\n    say \"Max: $max_value\";\n\n    foreach my $n (1 .. @rows) {\n\n        my $i      = 0;\n        my $offset = ($rows - $n) / 2;\n\n        my $row = $rows[$n - 1];\n\n        foreach my $elem (@$row) {\n\n            my $hue = map_value($elem, $min_value, $max_value, 1, 360);\n\n            $img->setpixel(\n                           x     => $offset + $i++,\n                           y     => $n,\n                           color => {\n                                     hsv => [$hue, 1, ($elem == $min_value) ? 0 : 1]\n                                    }\n                          );\n        }\n    }\n}\n\nspecial_pascal_triangle($size);\n\n$img->write(file => \"special_pascal_triangle.png\");\n"
  },
  {
    "path": "GD/pattern_triangle.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 26 May 2015\n# https://github.com/trizen\n\n#\n## Generate a pattern triangle based on square numbers (scaled down by a trivial constant)\n#\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse GD::Simple;\n\nsub generate {\n    my ($n, $data) = @_;\n\n    foreach my $i (0 .. $n) {\n        $data->{sprintf('%.0f', ($i**2) / 12000)} = 1;\n    }\n\n    return $n;\n}\n\nsay \"** Generating...\";\n\nmy %data;\nmy $max = generate(500000, \\%data);\nmy $limit = int(sqrt($max)) - 1;\n\n# create a new image\nmy $img = GD::Simple->new($limit * 2, $limit + 1);\n\nmy $i = 1;\nmy $j = 1;\n\nfor my $m (reverse(0 .. $limit)) {\n    $img->moveTo($m, $i - 1);\n\n    for my $n ($j .. $i**2) {\n        $img->fgcolor(exists($data{$j}) ? 'red' : 'black');\n        $img->line(1);\n        ++$j;\n    }\n    ++$i;\n}\n\nopen my $fh, '>:raw', \"pattern_triangle.png\";\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/peacock_triangles.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 26 August 2015\n# https://github.com/trizen\n\n#\n## Generate an interesting image containing some triangles with \"peacock tails\"\n#\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse GD::Simple;\n\nmy $max   = 1200000;               # duration: about 6 seconds\nmy $limit = int(sqrt($max)) - 1;\n\nmy $img = GD::Simple->new($limit * 12, $limit * 4);\n\nmy $i = 1;\nmy $j = 1;\n\n$img->turn(0.001);\n\nsay \"** Generating...\";\nfor my $m (reverse(0 .. $limit)) {\n    $img->moveTo($m * 12, 2 * ($i - 1));\n\n    for my $n ($j .. $i**2) {\n        $img->line(1);\n        ++$j;\n    }\n    ++$i;\n}\n\nopen my $fh, '>:raw', \"peacock_triangles.png\";\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/pi_abstract_art.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 02 February 2022\n# https://github.com/trizen\n\n# Generate a random art, using the digits of Pi in a given base.\n\n# See also:\n#   https://yewtu.be/watch?v=tkC1HHuuk7c\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse GD::Simple;\nuse ntheory qw(Pi todigits);\n\nmy $width  = 4000;\nmy $height = 5000;\n\n# create a new image\nmy $img = GD::Simple->new($width, $height);\n\n# move to the center\n$img->moveTo($width >> 1, $height >> 1);\n\nmy $digits    = 100000;    # how many of digits of pi to use\nmy $base      = 4;         # base\nmy $line_size = 7;         # size of the line\n\nmy $pi = join '', Pi($digits);\n$pi =~ s/\\.//;\n\nmy @digits = todigits($pi, $base);\nmy $theta  = 360 / $base;\n\nfor my $d (@digits) {\n    $img->turn($theta * $d);\n    $img->line($line_size);\n}\n\nopen my $fh, '>:raw', \"pi_abstract_art.png\";\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/pi_turtle.pl",
    "content": "#!/usr/bin/perl\n\nuse 5.014;\nuse strict;\nuse warnings;\n\nuse GD::Simple;\n\nmy $pi = do {\n    local $/;\n    <DATA> =~ tr/0-9//dcr;\n};\n\nmy $img = 'GD::Simple'->new(10000, 6000);\n$img->fgcolor('blue');\n$img->moveTo(5000, 3000);\n\nsub pi {\n    my $x = substr($pi, 0, 2, '');\n    $x =~ s/^0+//;\n    pi() if !length($x) and length($pi);\n    $x;\n}\n\nwhile (length($pi)) {\n    $img->fgcolor('white');\n\n    my $p_i = pi() || 0;\n    $img->line($p_i * ($p_i / sqrt($p_i + 1)) + $p_i);\n\n    foreach $_ (0 .. $p_i + $p_i) {\n        $img->fgcolor('green');\n        $img->turn($p_i);\n        $img->line(-$p_i);\n        $img->line(-$p_i);\n        $img->line(-$p_i);\n        $img->line(-$p_i);\n        $img->fgcolor('gray');\n        $img->turn(-$p_i);\n        $img->line($p_i);\n        $img->line($p_i);\n        $img->line($p_i);\n        $img->line($p_i);\n        $img->fgcolor('blue');\n        $img->turn(-$p_i);\n        $img->line($p_i);\n        $img->fgcolor('purple');\n        $img->turn($p_i);\n        $img->line(-$p_i);\n        $img->fgcolor('red');\n        $img->turn($p_i);\n        $img->line(-$p_i);\n    }\n}\n\nmy $image_name = 'pi_art_turtle.png';\nopen my $p, '>:raw', $image_name or die $!;\nprint $p $img->png;\nclose $p;\n\n__DATA__\n3.14159265358979323846264338327950288419716939937510582097494459230\n7816406286208998628034825342117067982148086513282306647093844609550\n5822317253594081284811174502841027019385211055596446229489549303819\n6442881097566593344612847564823378678316527120190914564856692346034\n8610454326648213393607260249141273724587006606315588174881520920962\n8292540917153643678925903600113305305488204665213841469519415116094\n3305727036575959195309218611738193261179310511854807446237996274956\n7351885752724891227938183011949129833673362440656643086021394946395\n2247371907021798609437027705392171762931767523846748184676694051320\n0056812714526356082778577134275778960917363717872146844090122495343\n0146549585371050792279689258923542019956112129021960864034418159813\n6297747713099605187072113499999983729780499510597317328160963185950\n2445945534690830264252230825334468503526193118817101000313783875288\n6587533208381420617177669147303598253490428755468731159562863882353\n7875937519577818577805321712268066130019278766111959092164201989380\n"
  },
  {
    "path": "GD/prime_consecutive_sums.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 18 August 2015\n# Website: https://github.com/trizen\n\n# This script plots the sums of consecutive primes\n\n## Example:\n# 2 + 2 = 4\n# 3 + 2 = 5\n# 3 + 3 = 6\n# 5 + 2 = 7\n# 5 + 3 = 8\n# 5 + 5 = 10\n# 7 + 2 = 9\n# 7 + 3 = 10\n# 7 + 5 = 12\n# 7 + 7 = 14\n\n# There are larger and larger overlaps, which suggests that\n# the ratio between p(n+1) and p(n) get smaller and smaller.\n\nuse 5.010;\nuse strict;\nuse integer;\n\nuse Imager qw();\nuse ntheory qw(primes);\n\nmy $primes = primes(500);\n\nmy $xsize = @{$primes}**2 + 1;\nmy $ysize = $primes->[-1] * 2 + 1;\n\nmy ($x, $y) = (0, $ysize);\nmy $img = Imager->new(xsize => $xsize, ysize => $ysize);\n\nmy $white = Imager::Color->new('#ffffff');\nmy $red   = Imager::Color->new('#ff0000');\n\n$img->box(filled => 1, color => $white);\n\nforeach my $p1 (@{$primes}) {\n    foreach my $p2 (@{$primes}) {\n        foreach my $i (1 .. ($p1 + $p2)) {\n            $img->setpixel(x => $x, y => $y - $i, color => $red);\n        }\n        $x += 1;\n    }\n    say $p1;\n}\n\n$img->write(file => \"prime_sums.png\");\n"
  },
  {
    "path": "GD/prime_gaps.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 29 July 2015\n# Website: https://github.com/trizen\n\n# Plot the differences between any two consecutive primes.\n\n# Example:\n#   29 - 23 = 6\n#   43 - 41 = 2\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager qw();\nuse ntheory qw(next_prime nth_prime);\n\nmy $limit = 1e4;\nmy $max   = -'inf';\n\nmy $last_prime = nth_prime($limit**3 * 3);    # start with this prime\n\nmy $xsize = $limit;\nmy $ysize = int(log($last_prime) * 10);       # approximation for the maximum difference\n\nmy ($x, $y) = (0, $ysize);\nmy $img = Imager->new(xsize => $xsize, ysize => $ysize);\n\nmy $white = Imager::Color->new('#FFFFFF');\nmy $gray  = Imager::Color->new('#5f5d5d');\n\n$img->box(filled => 1, color => $white);\n\nforeach my $i (1 .. $limit) {\n    my $prime = next_prime($last_prime);\n    my $diff  = $prime - $last_prime;\n\n    $max = $diff if $diff > $max;\n\n    foreach my $i (1 .. $diff) {\n        $img->setpixel(x => $x, y => $y - $i, color => $gray);\n    }\n\n    $last_prime = $prime;\n    $x += 1;\n}\n\nsay \"Maximum difference: $max\";\nsay \"Predicted difference: $ysize\";\n\n$img->write(file => \"prime_gaps.png\");\n"
  },
  {
    "path": "GD/prime_rectangles.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 23 May 2016\n# Website: https://github.com/trizen\n\n# Draw overlapping prime rectangles.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse GD::Simple;\nuse ntheory qw(forprimes prev_prime);\n\nmy $P = prev_prime(1000) + 1;\nmy $img = GD::Simple->new($P, $P);\n\n$img->bgcolor(undef);\n$img->fgcolor('red');\n\nforprimes {\n    my $p = $_;\n    forprimes {\n        $img->rectangle(1, 1, $_, $p);\n    } 0, $P;\n} 0, $P;\n\nopen my $fh, '>:raw', 'prime_rectangles.png';\nprint {$fh} $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/prime_stripe_triangle.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 02 April 2016\n# https://github.com/trizen\n\n# Generate a triangle with highlighted numbers that satisfy: (isqrt(n)-1)! = isqrt(n)-1 (mod isqrt(n)).\n# See also: https://oeis.org/A267016\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager;\nuse List::Util qw(max);\nuse Math::AnyNum qw(isqrt factorial);\n\nmy %data;\n\nsub generate {\n    my ($n) = @_;\n\n    foreach my $i (1 .. $n) {\n        my $j = isqrt($i);\n        if (factorial($j - 1) % $j == $j - 1) {\n            undef $data{$i + 1};\n        }\n    }\n\n    return 1;\n}\n\ngenerate(400000);\n\nmy $i = 1;\nmy $j = 1;\n\nmy $max   = max(keys %data);\nmy $limit = int(sqrt($max)) - 1;\n\n# Create a new image\nmy $img = Imager->new(xsize => $limit * 2, ysize => $limit + 1);\nmy $red = Imager::Color->new(255, 0, 0);\n\nfor my $m (0 .. $limit) {\n    my $x   = $limit - $m;\n    my $has = 0;\n    for my $n ($j .. $m**2) {\n        if (exists $data{$j}) {\n            $img->setpixel(x => $x, y => $m, color => $red);\n            $has ||= 1;\n        }\n        ++$x;\n        ++$j;\n    }\n    say $m- 1 if $has;\n}\n\n$img->write(file => 'prime_stripe_triangle.png');\n"
  },
  {
    "path": "GD/prime_triangle_90deg.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 14 September 2016\n# License: GPLv3\n# https://github.com/trizen\n\nuse strict;\nuse warnings;\n\nuse Imager;\n\nuse POSIX qw(ceil);\nuse ntheory qw(is_prime);\n\nmy $limit = 1000;\nmy $red   = Imager::Color->new('#ff0000');\n\nmy $img = Imager->new(xsize => 2 * $limit,\n                      ysize => $limit,);\n\nsub get_point {\n    my ($n) = @_;\n\n    my $row  = ceil(sqrt($n));\n    my $cell = 2 * $row - 1 - $row**2 + $n;\n\n    ($cell, $row);\n}\n\nforeach my $n (1 .. $limit**2) {\n    if (is_prime($n)) {\n        my ($x, $y) = get_point($n);\n        $img->setpixel(x => $x, y => $y, color => $red);\n    }\n}\n\n$img->write(file => 'prime_triangle_90deg.png');\n"
  },
  {
    "path": "GD/pythagoras_tree.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 08 June 2016\n# Website: https://github.com/trizen\n\n# See: https://rosettacode.org/wiki/Pythagoras_tree\n#      https://en.wikipedia.org/wiki/Pythagoras_tree_(fractal)\n\nuse Imager;\n\nsub tree {\n    my ($img, $x1, $y1, $x2, $y2, $depth) = @_;\n\n    return () if $depth <= 0;\n\n    my $dx = ($x2 - $x1);\n    my $dy = ($y1 - $y2);\n\n    my $x3 = ($x2 - $dy);\n    my $y3 = ($y2 - $dx);\n    my $x4 = ($x1 - $dy);\n    my $y4 = ($y1 - $dx);\n    my $x5 = ($x4 + 0.5 * ($dx - $dy));\n    my $y5 = ($y4 - 0.5 * ($dx + $dy));\n\n    # Square\n    $img->polygon(\n        points => [\n            [$x1, $y1],\n            [$x2, $y2],\n            [$x3, $y3],\n            [$x4, $y4],\n        ],\n        color => [0, 255 / $depth, 0],\n    );\n\n    # Triangle\n    $img->polygon(\n        points => [\n            [$x3, $y3],\n            [$x4, $y4],\n            [$x5, $y5],\n        ],\n        color => [0, 255 / $depth, 0],\n    );\n\n    tree($img, $x4, $y4, $x5, $y5, $depth - 1);\n    tree($img, $x5, $y5, $x3, $y3, $depth - 1);\n}\n\nmy ($width, $height) = (1920, 1080);\nmy $img = Imager->new(xsize => $width, ysize => $height);\n$img->box(filled => 1, color => 'white');\ntree($img, $width/2.3, $height, $width/1.8, $height, 10);\n$img->write(file => 'pythagoras_tree.png');\n"
  },
  {
    "path": "GD/random_abstract_art.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 08 June 2015\n# https://github.com/trizen\n\n#\n## Generate complex random art based on simple mathematics.\n#\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse GD::Simple;\nuse List::Util qw(shuffle);\n\nmy $max   = 1_000_000;\nmy $limit = int(sqrt($max));\n\nsay \"Possible combinations: $limit!\";\n\n# create a new image\nmy $img = GD::Simple->new($limit * 3, $limit * 3);\n\n# move to the center\n$img->moveTo($limit * 1.5, $limit * 1.5);\n\nmy $i = 1;\nmy $j = 1;\n\nfor my $m (shuffle(1 .. $limit)) {\n\n    for my $n ($j .. $i**2) {\n        $img->line(1);\n        $img->turn($n**2 / $m);\n        ++$j;\n    }\n\n    ++$i;\n}\n\nopen my $fh, '>:raw', \"random_abstract_art.png\";\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/random_abstract_art_2.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 08 June 2015\n# https://github.com/trizen\n\n#\n## Generate complex random art based on simple mathematics.\n#\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse GD::Simple;\n\nmy $max   = 1_000_000;\nmy $limit = int(sqrt($max));\n\n# create a new image\nmy $img = GD::Simple->new($limit * 3, $limit * 3);\n\n# move to the center\n$img->moveTo($limit * 1.5, $limit * 1.5);\n\nmy $i = 1;\nmy $j = 1;\n\nfor my $m (map { rand($limit) - rand($limit) } (1 .. $limit)) {\n\n    for my $n ($j .. $i**2) {\n        $img->line(1);\n        $img->turn($n**2 / $m);\n        ++$j;\n    }\n\n    ++$i;\n}\n\nopen my $fh, '>:raw', \"random_abstract_art_2.png\";\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/random_langton_s_ant.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# License: GPLv3\n# Date: 15 December 2013\n# Website: https://trizenx.blgospot.com\n\n# Variation of: https://rosettacode.org/wiki/Langton%27s_ant#Perl\n# More info about Langton's ant: https://en.wikipedia.org/wiki/Langton%27s_ant\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse GD::Simple;\n\nmy $width  = 12480;\nmy $height = 7020;\n\nmy $line = 10;     # line length\nmy $size = 1000;    # pattern size\n\nmy $turn_left_color  = 'red';\nmy $turn_right_color = 'black';\n\nmy $img_file = 'random_langton_s_ant.png';\n\nmy $p = GD::Simple->new($width, $height);\n$p->moveTo($width / 2, $height / 2);\n\n# Using screen coordinates - 0,0 in upper-left, +X right, +Y down -\n# these directions (right, up, left, down) are counterclockwise\n# so advance through the array to turn left, retreat to turn right\nmy @dirs = ([1, 0], [0, -1], [-1, 0], [0, 1]);\n\n# we treat any false as white and true as black, so undef is fine for initial all-white grid\nmy @plane;\nfor (0 .. $size - 1) { $plane[$_] = [(map {int(rand(2))} 1..rand(100)) x rand(100)] }\n\n# start out in approximate middle\nmy ($x, $y) = ($size / 2, $size / 2);\n\n# pointing in a random direction\nmy $dir = int rand @dirs;\n\n# turn in a random direction\n$p->turn(90 * $dir);\n\nmy $move;\nfor ($move = 0 ; $x >= 0 && $x < $size && $y >= 0 && $y < $size ; $move++) {\n\n    # toggle cell's value (white->black or black->white)\n    if ($plane[$x][$y] = 1 - ($plane[$x][$y] ||= 0)) {\n\n        # if it's now true (black), then it was white, so turn right\n        $p->fgcolor($turn_right_color);\n        $p->line($line);\n\n        # for more interesting patterns, try multiplying 90 with $dir\n        $p->turn(90);\n\n        $dir = ($dir - 1) % @dirs;\n    }\n    else {\n\n        # otherwise it was black, so turn left\n        $p->fgcolor($turn_left_color);\n        $p->line($line);\n        $p->turn(-90);\n\n        $dir = ($dir + 1) % @dirs;\n    }\n\n    $x += $dirs[$dir][0];\n    $y += $dirs[$dir][1];\n}\n\nopen my $fh, '>', $img_file\n  or die \"$img_file: $!\";\nprint {$fh} $p->png;\nclose $fh;\n"
  },
  {
    "path": "GD/random_looking_pattern_triangle.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 26 May 2015\n# https://github.com/trizen\n\n#\n## Generate a random-looking pattern triangle (but it's not random!)\n#\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse GD::Simple;\n\nsub generate {\n    my ($n, $data) = @_;\n\n    my $sum = 0;\n    foreach my $i (1 .. $n) {\n        if ($sum >= $i) {\n            $data->{$sum} = 1;\n            $sum -= int(sqrt($i) + 1);    # this is the \"random\" line\n        }\n        else {\n            $sum += $i;\n        }\n    }\n\n    return $n;\n}\n\nsay \"** Generating...\";\n\nmy %data;\nmy $max = generate(100000, \\%data);\nmy $limit = int(sqrt($max)) - 1;\n\n# create a new image\nmy $img = GD::Simple->new($limit * 2, $limit + 1);\n\nmy $i = 1;\nmy $j = 1;\n\nfor my $m (reverse(0 .. $limit)) {\n    $img->moveTo($m, $i - 1);\n\n    for my $n ($j .. $i**2) {\n        $img->fgcolor(exists($data{$j}) ? 'red' : 'black');\n        $img->line(1);\n        ++$j;\n    }\n    ++$i;\n}\n\nopen my $fh, '>:raw', \"random_looking_triangle.png\";\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/random_machinery_art.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 21 July 2015\n# https://github.com/trizen\n\n#\n## Generate a complex machine-like art based on simple mathematics.\n#\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse GD::Simple;\nuse List::Util qw(shuffle);\n\nmy $max   = 1_000_000;\nmy $limit = int(sqrt($max));\n\nsay \"Possible combinations: $limit!\";\n\n# create a new image\nmy $img = GD::Simple->new($limit * 3, $limit * 3);\n\n# move to the center\n$img->moveTo($limit * 1.5, $limit * 1.5);\n\nmy $i = 1;\nmy $j = 1;\n\nfor my $m (shuffle(1 .. $limit)) {\n\n    for my $n ($j .. $i**2) {\n        $img->line(1);\n        $img->turn($n * $i + $m);\n        ++$j;\n    }\n\n    ++$i;\n}\n\nopen my $fh, '>:raw', \"random_machinery.png\";\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/random_noise_triangle.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 26 May 2015\n# https://github.com/trizen\n\n#\n## Generate a random pattern triangle\n#\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse GD::Simple;\n\nsub generate {\n    my ($n, $data) = @_;\n\n    foreach my $i (1 .. $n) {\n        if (rand(1) < 0.5) {\n            $data->{$i} = 1;\n        }\n    }\n\n    return $n;\n}\n\nsay \"** Generating...\";\n\nmy %data;\nmy $max = generate(300000, \\%data);\nmy $limit = int(sqrt($max)) - 1;\n\n# create a new image\nmy $img = GD::Simple->new($limit * 2, $limit + 1);\n\nmy $i = 1;\nmy $j = 1;\n\nfor my $m (reverse(0 .. $limit)) {\n    $img->moveTo($m, $i - 1);\n\n    for my $n ($j .. $i**2) {\n        $img->fgcolor(exists($data{$j}) ? 'red' : 'black');\n        $img->line(1);\n        ++$j;\n    }\n    ++$i;\n}\n\nopen my $fh, '>:raw', \"random_noise_triangle.png\";\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/random_turtles.pl",
    "content": "#!/usr/bin/perl\n\nuse strict;\nuse warnings;\n\nuse GD::Simple;\n\n#use ntheory ('is_prime');\nprint \"** Generating image...\\n\";\n\nmy $img = 'GD::Simple'->new(10000, 6000);\n\n$img->fgcolor('blue');\n$img->moveTo(1000, 2000);\n\nfor (my $nr = 200 ; $nr <= 300 ; $nr += int rand 7) {\n    $img->fgcolor('white');\n\n    #$img->turn(-$nr);\n    #$img->line(300) if $nr < 100;\n    #$img->line($nr);\n    $img->line($nr * 2);\n\n    #$img->line( -$nr );\n\n    #$img->line($nr);\n    #if ( is_prime($nr) ) {\n    #$img->turn($nr);\n    #$img->turn($nr);\n    #$img->line( int rand -$nr );\n    #$img->turn( -$nr );\n    #$img->line( rand $nr );\n    #$img->line($nr);\n    #print \"$nr\\n\";\n    foreach $_ (0 .. (rand(100)) + 30) {\n        $img->fgcolor('green');\n        $img->turn($nr);\n        $img->line(-$nr);\n        $img->line(-$nr);\n        $img->line(-$nr);\n        $img->line(-$nr);\n\n        $img->fgcolor('gray');\n        $img->turn(-$nr);\n        $img->line($nr);\n        $img->line($nr);\n        $img->line($nr);\n        $img->line($nr);\n\n        #$img->line(-$nr);\n        #$img->line($nr);\n        #$img->line(-$nr);\n        #$img->line($nr);\n        #$img->line($nr);\n        #$img->line($nr);\n\n        $img->fgcolor('blue');\n        $img->turn(-$nr);\n        $img->line($nr);\n\n        #$img->line($nr);\n        #$img->line($nr);\n        #$img->line($nr);\n\n        $img->fgcolor('purple');\n        $img->turn($nr);\n\n        #$img->line( $nr );\n        #$img->line( $nr );\n        $img->line(-$nr);\n\n        #$img->line(-$nr);\n        #$img->line( $nr );\n\n        $img->fgcolor('red');\n        $img->turn($nr);\n\n        #$img->line( -$nr );\n        #$img->line( $nr );\n        $img->line(-$nr);\n\n        #$img->line(-$nr);\n        #$img->line(-$nr);\n        #$img->line(-$nr);\n        #$img->line(-$nr);\n        #$img->line(-$nr);\n    }\n\n    #}\n    #$img->fgcolor('white');\n    #$img->turn(-$nr);\n    my $a = ($nr * (int rand 4)) + (int rand 2000) + 4000;\n    my $b = ($nr * (int rand 4)) + (int rand 1000) + 1000;\n    $img->moveTo($a, $b) if $nr =~ /5$/;\n\n    #$img->turn(-$nr);\n    #$img->turn(-$nr);\n    #$img->line(-$nr*5+100);\n    #$img->line(-$nr);\n    #$img->line(-$nr);\n    #$img->line(-$nr);\n    #$img->line(-$nr);\n    #$img->line($nr);\n    #$img->line(-$nr);\n    #$img->line(-$nr);\n    #$img->line(-$nr);\n    #$img->line(-$nr);\n    #$img->line(-$nr);\n    #$img->line($nr);\n    #$img->line($nr);\n    #$img->line($nr);\n    #$img->line($nr);\n    #$img->line($nr);\n    #$img->line($nr);\n    #$img->line($nr);\n}\n\nopen(my $fh, '>:raw', 'random_turtles.png') or die $!;\nprint {$fh} $img->png;\nclose $fh;\n\nprint \"** Done\\n\";\n"
  },
  {
    "path": "GD/real_shell.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 30 April 2014\n# Website: https://github.com/trizen\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse GD::Simple;\n\nmy $img = 'GD::Simple'->new(500, 600);\n\nsub t($) {\n    $img->turn(shift);\n}\n\nsub l($) {\n    $img->line(shift);\n}\n\nsub c($) {\n    $img->fgcolor(shift);\n}\n\n$img->clear;\n$img->moveTo(250, 300);    # hopefully, at the center of the image\n\nmy $loop = 5;\nfor (my $j = 0.01 ; $j <= $loop ; $j += 0.01) {\n    l $j;\n    t $loop- $j + 1;\n}\n\nmy $image_name = \"shell.png\";\n\nopen my $fh, '>', $image_name or die $!;\nprint {$fh} $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/recursive_squares.pl",
    "content": "#!/usr/bin/perl\n\n# A nice recursive pattern, using the following rule:\n\n#           ---               |---|\n# | goes to  |  which goes to   |   and so on.\n#           ---               |---|\n\nuse 5.014;\nuse Imager;\n\nmy $xsize = 800;\nmy $ysize = 800;\n\nmy $img = Imager->new(xsize => $xsize, ysize => $ysize, channels => 3);\nmy $color = Imager::Color->new('#ff0000');\n\nsub a {\n    my ($x, $y, $len, $rep) = @_;\n\n    $img->line(\n               x1    => $x,\n               x2    => $x,\n               y1    => $y,\n               y2    => $y + $len,\n               color => $color,\n              );\n\n    f($x, $y, $len, $rep);\n}\n\nsub f {\n    my ($x, $y, $len, $rep) = @_;\n\n    $rep <= 0 and return;\n\n    $img->line(\n               x1    => $x - $len / 2,\n               x2    => $x + $len / 2,\n               y1    => $y,\n               y2    => $y,\n               color => $color,\n              );\n\n    g($x - $len / 2, $y, $len, $rep - 1);\n\n    $img->line(\n               x1    => $x - $len / 2,\n               x2    => $x + $len / 2,\n               y1    => $y + $len,\n               y2    => $y + $len,\n               color => $color,\n              );\n\n    g($x - $len / 2, $y + $len, $len, $rep - 1);\n}\n\nsub g {\n    my ($x, $y, $len, $rep) = @_;\n\n    $rep <= 0 and return;\n\n    $img->line(\n               x1    => $x,\n               x2    => $x,\n               y1    => $y - $len / 2,\n               y2    => $y + $len / 2,\n               color => $color,\n              );\n\n    f($x, $y - $len / 2, $len, $rep - 1);\n\n    $img->line(\n               x1    => $x + $len,\n               x2    => $x + $len,\n               y1    => $y - $len / 2,\n               y2    => $y + $len / 2,\n               color => $color,\n              );\n\n    f($x + $len, $y - $len / 2, $len, $rep - 1);\n}\n\na($xsize / 2, $ysize / 2, sqrt($xsize + $ysize), 12);\n\n$img->write(file => \"recursive_squares.png\");\n"
  },
  {
    "path": "GD/regular_poligons.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 16 July 2014\n# Website: https://github.com/trizen\n\nuse strict;\nuse warnings;\nuse GD::Simple;\n\nmy $img;\n\nsub t($) {\n    $img->turn(shift);\n}\n\nsub l($) {\n    $img->line(shift);\n}\n\nsub c($) {\n    $img->fgcolor(shift);\n}\n\nmy $dir = 'Regular poligons';\n\nif (not -d $dir) {\n    mkdir($dir) || die \"Can't mkdir `$dir': $!\";\n}\n\nchdir($dir) || die \"Can't chdir `$dir': $!\";\n\nforeach my $i (1 .. 144) {\n    if (360 % (180 - $i) == 0) {\n\n        my $sides = 360 / (180 - $i);\n        printf(\"Angle: %d\\tSides: %d\\n\", $i, $sides);\n\n        $img = 'GD::Simple'->new(1000, 1000);\n        $img->moveTo(500, 500);\n\n        for (1 .. $sides) {\n            l 150;\n            t 180 - $i;\n        }\n\n        my $image_name = sprintf(\"%03d.png\", $i);\n        open my $fh, '>:raw', $image_name or die $!;\n        print {$fh} $img->png;\n        close $fh;\n    }\n}\n"
  },
  {
    "path": "GD/reversed_prime_triangles.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 26 July 2015\n# Website: https://github.com/trizen\n\n# Generate a reversed set of number triangles\n# with the prime numbers represented by blue pixels.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager qw();\nuse ntheory qw(is_prime);\n\nsub triangle {\n    my ($rows, $type) = @_;\n\n    my @triangle = ([1]);\n\n    my $n = 1;\n    foreach my $i (1 .. $rows) {\n\n        if ($type == 1) {\n            foreach my $j (0 .. $#triangle) {\n                push @{$triangle[$j]}, ++$n;\n                unshift @{$triangle[$j]}, ++$n;\n            }\n        }\n        elsif ($type == 2) {\n            foreach my $j (reverse 0 .. $#triangle) {\n                push @{$triangle[$j]}, ++$n;\n                unshift @{$triangle[$j]}, ++$n;\n            }\n        }\n        elsif ($type == 3) {\n            foreach my $j (0 .. $#triangle) {\n                unshift @{$triangle[$j]}, ++$n;\n            }\n            foreach my $j (reverse 0 .. $#triangle) {\n                push @{$triangle[$j]}, ++$n;\n            }\n        }\n        elsif ($type == 4) {\n            foreach my $j (reverse 0 .. $#triangle) {\n                unshift @{$triangle[$j]}, ++$n;\n            }\n            foreach my $j (0 .. $#triangle) {\n                push @{$triangle[$j]}, ++$n;\n            }\n        }\n        else {\n            die \"Invalid type: $type\";\n        }\n\n        unshift @triangle, [++$n];\n    }\n\n    return \\@triangle;\n}\n\nsub triangle2img {\n    my ($triangle) = @_;\n\n    my $rows = $#{$triangle} + 1;\n\n    my $blue  = Imager::Color->new('#0000FF');\n    my $white = Imager::Color->new('#FFFFFF');\n\n    my $img = Imager->new(xsize => $rows * 2, ysize => $rows);\n    $img->box(filled => 1, color => $white);\n\n    foreach my $i (0 .. $rows - 1) {\n        my $row = $triangle->[$i];\n\n        foreach my $j (0 .. $#{$row}) {\n            my $num = $row->[$j];\n            if (is_prime($num)) {\n                $img->setpixel(x => $rows - $i + $j, y => $i, color => $blue);\n            }\n            else {\n                $img->setpixel(x => $rows - $i + $j, y => $i, color => $white);\n            }\n        }\n    }\n\n    return $img;\n}\n\nmy $max  = 4;\nmy $rows = 1000;\n\nforeach my $i (1 .. $max) {\n    say \"** Generating triangle $i of $max...\";\n\n    my $triangle = triangle($rows, $i);\n    my $img = triangle2img($triangle);\n\n    $img->write(file => \"reversed_triangle_$i.png\");\n}\n"
  },
  {
    "path": "GD/right_triangle_primes.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 11 April 2015\n# https://github.com/trizen\n\n# A number triangle, with the primes highlighted in blue\n# (there are some lines that have more primes than others)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse GD::Simple;\nuse ntheory qw(is_prime);\n\nmy $n = 1000000;    # duration: about 5 seconds\n\nsub limit {\n    my ($n) = @_;\n    (sqrt(8 * $n + 1) - 1) / 2;\n}\n\nsub round {\n    my ($n) = @_;\n    ($n**2 + $n) / 2;\n}\n\nmy $lim = int(limit($n));\nmy $num = round($lim);\n\n# create a new image\nmy $img = GD::Simple->new($lim, $lim);\n\nmy $counter = 1;\nmy $white   = 1;\n$img->fgcolor('white');\n\nforeach my $i (0 .. $lim - 1) {\n    $img->moveTo(0, $i);\n    foreach my $j (0 .. $i) {\n        ##print $counter, ' ';\n        if (is_prime($counter)) {\n            if ($white) {\n                $img->fgcolor('blue');\n                $white = 0;\n            }\n        }\n        elsif (not $white) {\n            $img->fgcolor('white');\n            $white = 1;\n        }\n        $img->line(1);\n        ++$counter;\n    }\n    ##print \"\\n\";\n}\n\nopen my $fh, '>:raw', 'right_triangle_primes.png';\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/sandpiles.pl",
    "content": "#!/usr/bin/perl\n\n# Simulate the toppling of sandpiles.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Abelian_sandpile_model\n#   https://www.youtube.com/watch?v=1MtEUErz7Gg -- ‎Sandpiles - Numberphile\n#   https://www.youtube.com/watch?v=diGjw5tghYU -- ‎Coding Challenge #107: Sandpiles (by Daniel Shiffman)\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Imager;\nuse experimental qw(signatures);\n\npackage Sandpile {\n\n    sub new ($class, %opt) {\n\n        my $state = {\n                     width  => 100,\n                     height => 100,\n                     %opt,\n                    };\n\n        bless $state, $class;\n    }\n\n    sub create_plane ($self) {\n        [map { [(0) x $self->{width}] } 1 .. $self->{height}];\n    }\n\n    sub topple ($self, $plane) {\n\n        my $nextplane = $self->create_plane;\n\n        foreach my $y (0 .. $self->{height} - 1) {\n            foreach my $x (0 .. $self->{width} - 1) {\n                my $pile = $plane->[$y][$x];\n\n                if ($pile < 4) {\n                    $nextplane->[$y][$x] = $pile;\n                }\n            }\n        }\n\n        foreach my $y (1 .. $self->{height} - 2) {\n            foreach my $x (1 .. $self->{width} - 2) {\n                my $pile = $plane->[$y][$x];\n\n                if ($pile >= 4) {\n                    $nextplane->[$y][$x] += $pile - 4;\n                    $nextplane->[$y - 1][$x]++;\n                    $nextplane->[$y + 1][$x]++;\n                    $nextplane->[$y][$x - 1]++;\n                    $nextplane->[$y][$x + 1]++;\n                }\n            }\n        }\n\n        return $nextplane;\n    }\n\n    sub generate ($self, $pile_of_sand, $topple_times) {\n\n        my $plane = $self->create_plane;\n        $plane->[$self->{height} / 2][$self->{width} / 2] = $pile_of_sand;\n\n        for (1 .. $topple_times) {\n            $plane = $self->topple($plane);\n        }\n\n        my $img    = Imager->new(xsize => $self->{width}, ysize => $self->{height});\n        my @colors = map { Imager::Color->new($_) } ('black', 'blue', 'green', 'white');\n\n        foreach my $y (0 .. $self->{height} - 1) {\n            foreach my $x (0 .. $self->{width} - 1) {\n\n                my $pile = $plane->[$y][$x];\n\n                if ($pile <= 3) {\n                    $img->setpixel(x => $x, y => $y, color => $colors[$pile]);\n                }\n            }\n        }\n\n        return $img;\n    }\n}\n\nmy $obj = Sandpile->new;\nmy $img = $obj->generate(10**5, 10**4);\n\n$img->write(file => 'sandpiles.png');\n"
  },
  {
    "path": "GD/sierpinski_fibonacci_triangle.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 12 October 2017\n# https://github.com/trizen\n\n# Generation of the Sierpinski triangle form a lagged Fibonacci sequence mod 2.\n\n# See also:\n#   https://projecteuler.net/problem=258\n#   https://en.wikipedia.org/wiki/Sierpinski_triangle\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Imager;\nuse experimental qw(signatures);\n\nmy $size = 1000;\nmy $red  = Imager::Color->new('#ff0000');\n\nmy $img = Imager->new(xsize => $size,\n                      ysize => $size);\n\nsub fibmod_seq ($n, $lag, $mod) {\n\n    my @g = (1) x $lag;\n\n    foreach my $k ($lag .. $n) {\n\n        my $x = $g[$k - $lag];\n        my $y = $g[$k - $lag - 1];\n\n        $g[$k] = ($x + $y) % $mod;\n    }\n\n    return @g;\n}\n\nmy $n   = $size**2;\nmy $lag = $size;\nmy $mod = 2;\n\nmy @g = fibmod_seq($n, $lag, $mod);\n\nforeach my $i (0 .. $#g) {\n\n    if ($g[$i]) {\n        $img->setpixel(\n                       x     => $i % $lag,\n                       y     => int($i / $lag),\n                       color => $red,\n                      );\n    }\n}\n\n$img->write(file => 'sierpinski_fibonacci_triangle.png');\n"
  },
  {
    "path": "GD/sierpinski_triangle.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 20 December 2014\n# https://github.com/trizen\n\n# Generate a graphical Sierpinski triangle of a given size.\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse GD::Simple;\n\nsub sierpinski {\n    my ($n)   = @_;\n    my @down  = '*';\n    my $space = ' ';\n    foreach (1 .. $n) {\n        @down = (map({ $space . $_ . $space } @down), map({ $_ . ' ' . $_ } @down));\n        $space = $space . $space;\n    }\n    return @down;\n}\n\nmy @lines = sierpinski(8);\n\nmy $size = $ARGV[0] // 2;\nmy $img = GD::Simple->new(length($lines[0]) * $size, scalar(@lines) * $size);\n\nforeach my $i (0 .. $#lines) {\n    foreach my $j ($i * $size .. $i * $size + $size) {\n        $img->moveTo(0, $j);\n        my $row = $lines[$i];\n        while (1) {\n            if ($row =~ s/^(\\s+)//) {\n                $img->fgcolor('black');\n                $img->line($size * length($1));\n            }\n            elsif ($row =~ s/^(\\S+)//) {\n                $img->fgcolor('red');\n                $img->line($size * length($1));\n            }\n            else {\n                last;\n            }\n        }\n    }\n}\n\nopen my $fh, '>:raw', 'triangle.png';\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/spinning_shapes.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 30 April 2014\n# Website: https://github.com/trizen\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse GD::Simple;\n\nmy $img = 'GD::Simple'->new(2000, 2000);\n$img->fgcolor('blue');\n\nsub t($) {\n    $img->turn(shift);\n}\n\nsub l($) {\n    $img->line(shift);\n}\n\nsub c($) {\n    $img->fgcolor(shift);\n}\n\nmy $dir = 'Spinning Shapes';\n\nif (not -d $dir) {\n    mkdir($dir) || die \"Can't mkdir `$dir': $!\";\n}\n\nchdir($dir) || die \"Can't chdir `$dir': $!\";\n\nfor (my $i = 1 ; $i <= 180 ; $i += 1) {\n\n    say \"$i degrees\";\n\n    $img->clear;\n    $img->moveTo(1000, 1000);    # hopefully, at the center of the image\n\n    for my $j (1 .. 360) {\n        l($j * 2);\n        t $i;\n    }\n\n    my $image_name = sprintf(\"%03d.png\", $i);\n\n    open my $fh, '>:raw', $image_name or die $!;\n    print {$fh} $img->png;\n    close $fh;\n}\n"
  },
  {
    "path": "GD/spiral_matrix_primes.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 13 April 2015\n# https://github.com/trizen\n\n# A number spiral matrix, with the primes highlighted in blue\n# (there are some lines that have more primes than others)\n\n# Inspired by: https://www.youtube.com/watch?v=iFuR97YcSLM\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse GD::Simple;\nuse ntheory qw(is_prime);\n\nmy $n = 1847;    # duration: about 22 seconds\n\nsub spiral {\n    my ($n, $x, $y, $dx, $dy, @a) = (shift, 0, 0, 1, 0);\n    foreach my $i (0 .. $n**2 - 1) {\n        $a[$y][$x] = $i;\n        my ($nx, $ny) = ($x + $dx, $y + $dy);\n        ($dx, $dy) =\n            $dx == 1  && ($nx == $n || defined $a[$ny][$nx]) ? (0,  1)\n          : $dy == 1  && ($ny == $n || defined $a[$ny][$nx]) ? (-1, 0)\n          : $dx == -1 && ($nx < 0   || defined $a[$ny][$nx]) ? (0,  -1)\n          : $dy == -1 && ($ny < 0   || defined $a[$ny][$nx]) ? (1,  0)\n          :                                                    ($dx, $dy);\n        ($x, $y) = ($x + $dx, $y + $dy);\n    }\n    return \\@a;\n}\n\nsay \"** Generating the matrix...\";\nmy $matrix = spiral($n);\n\nsay \"** Generating the image...\";\nmy $img = GD::Simple->new($n, $n);\n\nmy $white = 1;\n$img->fgcolor('white');\n\nforeach my $y (0 .. $#{$matrix}) {\n    $img->moveTo(0, $y);\n\n    foreach my $num (@{$matrix->[$y]}) {\n        if (is_prime($num)) {\n            if ($white) {\n                $img->fgcolor('blue');\n                $white = 0;\n            }\n        }\n        elsif (not $white) {\n            $img->fgcolor('white');\n            $white = 1;\n        }\n        $img->line(1);\n    }\n}\n\nopen my $fh, '>:raw', 'spiral_primes.png';\nprint $fh $img->png;\nclose $fh;\n\nsay \"** Done!\";\n"
  },
  {
    "path": "GD/spiral_tree.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 13 August 2015\n# https://github.com/trizen\n\n# Generate a spiral tree with branches\n# Inspired from: https://www.youtube.com/watch?v=RWAcbV4X7C8\n\nuse GD::Simple;\nmy $img = GD::Simple->new(1000, 700);\n\n$img->moveTo(500, 650);\n$img->turn(-90);\n\nsub branch {\n    my ($len) = @_;\n\n    $img->line($len);\n    $len *= 0.64;\n\n    if ($len > 2) {\n\n        my @pos1   = $img->curPos;\n        my $angle1 = $img->angle;\n\n        $img->turn(45);\n        branch($len);\n        $img->moveTo(@pos1);\n        $img->angle($angle1);\n\n        my @pos2   = $img->curPos;\n        my $angle2 = $img->angle;\n\n        $img->turn(-90);\n        branch($len);\n        $img->moveTo(@pos2);\n        $img->angle($angle2);\n    }\n}\n\nbranch(250);\n\nopen my $fh, '>:raw', 'spiral_tree.png';\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/square_of_circles.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 19 December 2016\n# https://github.com/trizen\n\n# Draws a square with diagonals made out of circles.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse GD::Simple;\n\nmy $img = 'GD::Simple'->new(1000, 1000);\n$img->fgcolor('blue');\n$img->bgcolor(undef);\n$img->moveTo(200, 150);\n\nmy $n    = 15;\nmy $size = 45;\n\nmy $dsize = $size / (1 + sqrt(2));\nmy $dmove = $size / 4;\n\nfor (1 .. $n) {\n    my ($x, $y) = $img->curPos;\n    $img->moveTo($x, $y + $size);\n    $img->ellipse($size, $size);\n}\n\nfor (1 .. $n - 1) {\n    my ($x, $y) = $img->curPos;\n    $img->moveTo($x + $size, $y);\n    $img->ellipse($size, $size);\n}\n\nfor (1 .. $n - 1) {\n    my ($x, $y) = $img->curPos;\n    $img->moveTo($x, $y - $size);\n    $img->ellipse($size, $size);\n}\n\nmy ($x, $y) = $img->curPos;\n\nfor (1 .. $n - 1) {\n    my ($x, $y) = $img->curPos;\n    $img->moveTo($x - $size, $y);\n    $img->ellipse($size, $size);\n}\n\nfor (1 .. 4 * ($n - 1) - 2) {\n    my ($x, $y) = $img->curPos;\n    $img->moveTo($x + $dmove, $y + $dmove);\n    $img->ellipse($dsize, $dsize) if $_ > 1;\n}\n\n$img->moveTo($x, $y);\n\nfor (1 .. 4 * ($n - 1) - 2) {\n    my ($x, $y) = $img->curPos;\n    $img->moveTo($x - $dmove, $y + $dmove);\n    $img->ellipse($dsize, $dsize) if $_ > 1;\n}\n\nopen my $fh, '>:raw', 'square_of_circles.png';\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/star_turtle.pl",
    "content": "#!/usr/bin/perl\n\nuse strict;\nuse warnings;\n\nuse GD::Simple;\n\nmy $img = 'GD::Simple'->new(2500, 2500);\n$img->moveTo(1220, 1220);\n\nmy $nr = 360.01;\n\nfor (0 .. 150) {\n    $img->turn(-$nr);\n    $img->line($nr);\n    $img->turn(180);\n    $img->line(-$nr);\n    $img->line($nr);\n    $img->turn(45);\n    $img->line(-$nr);\n    $img->turn(180);\n    $img->line($nr);\n    $img->line(-$nr);\n    $img->turn(45);\n    $img->line($nr);\n    $img->turn(180);\n    $img->line(-$nr);\n    $img->line($nr);\n    $img->turn(45);\n    $img->line(-$nr);\n    $img->turn(180);\n    $img->line($nr);\n    $img->line(-$nr);\n    $img->turn(45);\n    $img->line($nr);\n    $img->turn(180);\n    $img->line(-$nr);\n    $img->line($nr);\n    $img->turn(45);\n    $img->line(-$nr);\n    $img->turn(180);\n    $img->line($nr);\n    $img->line(-$nr);\n    $img->turn(45);\n    $img->line($nr);\n    $img->turn(180);\n    $img->line(-$nr);\n    $img->line($nr);\n    $img->turn(45);\n    $img->line(-$nr);\n    $img->turn(180);\n    $img->line($nr);\n    $img->line(-$nr);\n}\n\nmy $image_name = 'star_turtle.png';\n\nopen my $fh, '>:raw', $image_name or die $!;\nprint {$fh} $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/stern_brocot_shapes.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 18 July 2015\n# https://github.com/trizen\n\n#\n## Generate an interesting cluster of shapes based on the Stern-Brocot sequence.\n#\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse GD::Simple;\n\nmy $img = 'GD::Simple'->new(5000, 5000);\n$img->moveTo(2100, 2500);\n\nsub t($) {\n    $img->turn(shift);\n}\n\nsub l($) {\n    $img->line(shift);\n}\n\nsub c($) {\n    $img->fgcolor(shift);\n}\n\nsub stern_brocot(&$) {\n    my ($callback, $n) = @_;\n\n    my @fib = (1, 1);\n    foreach my $i (1 .. $n) {\n        push @fib, $fib[0] + $fib[1], $fib[1];\n        $callback->($fib[0]);\n        shift @fib;\n    }\n    $callback->($_) for @fib;\n}\n\nc 'red';\nfor my $i (1 .. 180) {\n    stern_brocot {\n        l $i/ $_[0];\n        t $i;\n    }\n    $i;\n    t 0;\n}\n\nmy $image_name = 'stern_brocot_shapes.png';\n\nopen my $fh, '>:raw', $image_name or die $!;\nprint {$fh} $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/triangle_factors.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 07 August 2016\n# https://github.com/trizen\n\n# A number triangle, where each number is highlighted with\n# a different color based on the number of its prime factors.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse GD::Simple;\nuse ntheory qw(factor is_prime);\nuse List::Util qw(shuffle);\n\nmy @color_names = grep { !/white|gradient/ } shuffle(GD::Simple->color_names);\n\nmy $i = 1;\nmy $j = 1;\n\nmy $n = shift(@ARGV) // 1000000;    # duration: about 10 seconds\nmy $limit = int(sqrt($n)) - 1;\n\nmy %colors;\n\n# create a new image\nmy $img = GD::Simple->new($limit * 2, $limit + 1);\n\nmy $white = 0;\nfor my $m (reverse(0 .. $limit)) {\n    $img->moveTo($m, $i - 1);\n\n    for my $n ($j .. $i**2) {\n        my $f = factor($j);\n        if ($f > 0 and $f <= @color_names) {\n            $img->fgcolor($color_names[$f - 1]);\n            $colors{$f} = $color_names[$f - 1];\n        }\n        else {\n            $img->fgcolor('white');\n        }\n        $img->line(1);\n        ++$j;\n    }\n    ++$i;\n}\n\nforeach my $key (sort { $a <=> $b } keys %colors) {\n    say \"$key\\t : $colors{$key}\";\n}\n\nopen my $fh, '>:raw', 'triangle_factors.png';\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/triangle_primes.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 10 April 2015\n# https://github.com/trizen\n\n# A number triangle, with the primes highlighted in blue\n# (there are some lines that have more primes than others)\n\n# Inspired by: https://www.youtube.com/watch?v=iFuR97YcSLM\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse GD::Simple;\nuse ntheory qw(is_prime);\n\nmy $i = 1;\nmy $j = 1;\n\nmy $n = shift(@ARGV) // 8000000;    # duration: about 45 seconds\nmy $limit = int(sqrt($n)) - 1;\n\nmy %top;                            # count the number of primes on vertical lines\nmy $top = 10;                       # how many lines to display at the end\n\n# create a new image\nmy $img = GD::Simple->new($limit * 2, $limit + 1);\n\nmy $white = 0;\nfor my $m (reverse(0 .. $limit)) {\n    ##print \" \" x $m;\n    my $pos = $m;\n    $img->moveTo($m, $i - 1);\n\n    for my $n ($j .. $i**2) {\n        ##print $j;\n        if (is_prime($j)) {\n            $white = 0;\n            $img->fgcolor('blue');\n            $top{$pos}{count}++;\n            $top{$pos}{first} //= $j;\n        }\n        elsif (not $white) {\n            $white = 1;\n            $img->fgcolor('white');\n        }\n        $img->line(1);\n        ++$pos;\n        ++$j;\n    }\n    ++$i;\n    ##print \"\\n\";\n}\n\nsay \"=> Top vertical lines: \";\nforeach my $i (sort { $top{$b}{count} <=> $top{$a}{count} } keys %top) {\n    state $counter = 0;\n    say \"$i:\\t$top{$i}{count} (first prime: $top{$i}{first})\";\n    last if ++$counter == $top;\n}\n\nopen my $fh, '>:raw', 'triangle_primes.png';\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/triangle_primes_2.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 18 April 2015\n# https://github.com/trizen\n\n# A number triangle, with the primes highlighted in blue\n# (there are some lines that have more primes than others)\n\n# Inspired by: https://www.youtube.com/watch?v=iFuR97YcSLM\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse GD::Simple;\nuse ntheory qw(is_prime);\n\nmy $i   = 1;\nmy $max = 2000;    # duration: about 11 seconds\n\n# create a new image\nmy $img = GD::Simple->new($max, $max);\n\nmy $white = 0;\n$img->fgcolor('blue');\n\nforeach my $x (1 .. $max) {\n\n    $img->moveTo(0, $x - 1);\n\n    foreach my $y (1 .. $x) {\n        if (is_prime($i)) {\n            $white = 0;\n            $img->fgcolor('blue');\n        }\n        elsif (not $white) {\n            $white = 1;\n            $img->fgcolor('white');\n        }\n\n        $img->line(1);\n        ++$i;\n    }\n}\n\nopen my $fh, '>:raw', 'triangle_primes_2.png';\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/triangle_primes_irregular.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 10 April 2015\n# https://github.com/trizen\n\n# A number triangle, with the primes highlighted in blue\n\n## Vertical lines are represented by:\n# n^2 - 2n + 2\n# n^2 - n + 1\n# n^2\n# n^2 + n - 1\n# n^2 + 2n - 2\n# ...\n\n## Horizontal lines are represented by:\n# 1\n# n + 1\n# 2n + 3\n# 3n + 7\n# 4n + 13\n# 5n + 21\n# 6n + 31\n# 7n + 43\n# ...\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse GD::Simple;\nuse ntheory qw(is_prime);\n\nmy $rows = shift(@ARGV) // 2000;    # duration: about 12 seconds\nmy $white = 1;\n\n# create a new image\nmy $img = GD::Simple->new($rows, $rows);\n$img->fgcolor('white');\n\nforeach my $i (0 .. $rows - 1) {\n    $img->moveTo(0, $i);\n    foreach my $j ($i .. $rows - 1) {\n        my $num = $i * $j + 1;\n\n        #printf \"%3d%s\", $num, ' ';\n        if (is_prime($num)) {\n            if ($white) {\n                $img->fgcolor('blue');\n                $white = 0;\n            }\n        }\n        elsif (not $white) {\n            $img->fgcolor('white');\n            $white = 1;\n        }\n\n        $img->line(1);\n    }\n\n    #print \"\\n\";\n}\n\nopen my $fh, '>:raw', 'triangle_primes_irregular.png';\nprint $fh $img->png;\nclose $fh;\n\n__END__\n  1   1   1   1   1   1   1   1   1   1   1   1   1   1   1   1   1   1   1   1\n  2   3   4   5   6   7   8   9  10  11  12  13  14  15  16  17  18  19  20\n  5   7   9  11  13  15  17  19  21  23  25  27  29  31  33  35  37  39\n 10  13  16  19  22  25  28  31  34  37  40  43  46  49  52  55  58\n 17  21  25  29  33  37  41  45  49  53  57  61  65  69  73  77\n 26  31  36  41  46  51  56  61  66  71  76  81  86  91  96\n 37  43  49  55  61  67  73  79  85  91  97 103 109 115\n 50  57  64  71  78  85  92  99 106 113 120 127 134\n 65  73  81  89  97 105 113 121 129 137 145 153\n 82  91 100 109 118 127 136 145 154 163 172\n101 111 121 131 141 151 161 171 181 191\n122 133 144 155 166 177 188 199 210\n145 157 169 181 193 205 217 229\n170 183 196 209 222 235 248\n197 211 225 239 253 267\n226 241 256 271 286\n257 273 289 305\n290 307 324\n325 343\n362\n"
  },
  {
    "path": "GD/trizen_fan_turtle.pl",
    "content": "#!/usr/bin/perl\n\nuse strict;\nuse warnings;\n\nuse GD::Simple;\n\nmy $img = 'GD::Simple'->new(2503, 2500);\n$img->moveTo(540, 1980);\n\nmy $nr = 360;\n\nfor (0 .. 20) {\n\n    # T\n    $img->fgcolor('purple');\n    $img->turn(-90);\n    $img->line(--$nr / 10);\n    $img->turn(90);\n    $img->line($nr);\n    $img->turn(90);\n    $img->line($nr / 10);\n    $img->turn(90);\n    $img->move($nr / 2);\n    $img->turn(90);\n    $img->move($nr / 10);\n    $img->turn(-180);\n    $img->line($nr);\n    $img->turn(-90);\n\n    # R\n    $img->fgcolor('green');\n    $img->move($nr / 1.5);\n    $img->turn(-90);\n    $img->line($nr);\n    $img->turn(90);\n    $img->line($nr / 2 - ($nr / 10));\n    $img->turn(45);\n    $img->line($nr / 10);\n    $img->turn(90 - 45);\n    $img->line($nr / 2 - ($nr / 10));\n    $img->turn(45);\n    $img->line($nr / 10);\n    $img->turn(90 - 45);\n    $img->line($nr / 2 - ($nr / 10));\n    $img->turn(-180 + 45);\n    $img->line($nr / 2 + ($nr / 4) - ($nr / 10));\n    $img->turn(-180 + 45);\n    $img->line($nr / 10);\n    $img->turn(180);\n    $img->move($nr / 10);\n\n    $nr -= ($_);\n\n    # I\n    $img->fgcolor('black');    # blue\n    $img->turn(-90);\n    $img->move($nr / 4);\n    $img->turn(-90);\n    $img->line($nr);\n    $img->move($nr / 10);\n    $img->turn(180);\n    $img->move($nr / 10 + 12 + (12 / 2));\n    $img->turn(-90);\n    $img->move($nr / 5);\n\n    # star\n    $img->line(12);\n    $img->turn(180);\n    $img->line(-12);\n    $img->line(12);\n    $img->turn(45);\n    $img->line(-12);\n    $img->turn(180);\n    $img->line(12);\n    $img->line(-12);\n    $img->turn(45);\n    $img->line(12);\n    $img->turn(180);\n    $img->line(-12);\n    $img->line(12);\n    $img->turn(45);\n    $img->line(-12);\n    $img->turn(180);\n    $img->line(12);\n    $img->line(-12);\n    $img->turn(45);\n    $img->line(12);\n    $img->turn(180);\n    $img->line(-12);\n    $img->line(12);\n    $img->turn(45);\n    $img->line(-12);\n    $img->turn(180);\n    $img->line(12);\n    $img->line(-12);\n    $img->turn(45);\n    $img->line(12);\n    $img->turn(180);\n    $img->line(-12);\n    $img->line(12);\n    $img->turn(45);\n    $img->line(-12);\n    $img->turn(180);\n    $img->line(12);\n    $img->line(-12);\n    $nr += ($_);\n\n    # Z\n    $img->fgcolor('red');\n    $img->turn(-45);\n    $img->move($nr + (12 * 6));\n    $img->turn(-90);\n    $img->move($nr / 7);\n    $img->turn(-65);\n    $img->line($nr + ($nr / 10));\n    $img->turn(-180 + 65);\n    $img->line($nr / 2);\n    $img->turn(-90);\n    $img->line($nr / 10);\n    $img->turn(180);\n    $img->move($nr / 10);\n    $img->turn(90 + 65);\n    $img->move($nr + ($nr / 10));\n    $img->turn(-90 - 65);\n    $img->line($nr / 10);\n    $img->turn(180);\n    $img->move($nr / 10);\n    $img->turn(90);\n    $img->line($nr / 2 - ($nr / 7) / 2);\n    $img->turn(180 - 65);\n    $img->move(($nr + ($nr / 10)) / 2);\n    $img->turn(-180 + 65);\n    $img->line($nr / 4);\n    $img->turn(-90);\n    $img->line($nr / 10);\n    $img->turn(180);\n    $img->move($nr / 10);\n    $img->turn(90);\n    $img->line($nr / 2);\n    $img->turn(-90);\n    $img->line($nr / 10);\n\n    # E\n    $img->fgcolor('orange');\n    $img->turn(180);\n    $img->move($nr / 2 + ($nr / 10));\n    $img->turn(-90);\n    $img->move($nr / 5);\n    $img->turn(-90);\n    $img->line($nr);\n    $img->turn(90);\n    $img->line($nr / 2);\n    $img->turn(90);\n    $img->move($nr / 2);\n    $img->turn(90);\n    $img->line($nr / 2);\n    $img->turn(-90);\n    $img->move($nr / 2);\n    $img->line($nr / 2);\n\n    # N\n    $img->fgcolor('blue');\n    $img->turn(0);\n    $img->move($nr / 4);\n    $img->turn(-90);\n    $img->line($nr);\n    $img->turn(90 + 65);\n    $img->line($nr + ($nr / 10));\n    $img->turn(-90 - 65);\n    $img->line($nr);\n}\n\n$nr = 308.5 - (308.5 / 8);\n$img->moveTo(830, 1380);\n\nfor (0 .. 623) {\n    $img->fgcolor('green');\n    $img->turn($nr);\n    $img->line(-$nr);\n    $img->line(-$nr);\n    $img->line(-$nr);\n    $img->line(-$nr);\n    $img->fgcolor('black');\n    $img->turn(-$nr);\n    $img->line($nr);\n    $img->line($nr);\n    $img->line($nr);\n    $img->line($nr);\n    $img->turn(-$nr);\n    $img->line($nr);\n    $img->fgcolor('red');\n    $img->turn($nr);\n    $img->line(-$nr);\n    $img->fgcolor('red');\n    $img->line(-$nr);\n}\n\nmy $image_name = 'trizen_fan_turtle.png';\n\nopen my $fh, '>:raw', $image_name or die $!;\nprint {$fh} $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/trizen_flat_logo.pl",
    "content": "#!/usr/bin/perl\n\nuse strict;\nuse warnings;\n\nuse GD::Simple;\n\nmy $img = 'GD::Simple'->new(2300, 2300);\n$img->moveTo(465, 1305);\n\nmy $nr = 308.5;\n\nfor (0 .. 222) {\n    $img->fgcolor(qw(blue green) [$_ % 2]);\n    $img->turn(45);\n    $img->line(-$nr - $_);\n    $img->line(-$nr);\n    $img->line(-$nr);\n    $img->line(-$nr);\n    $img->fgcolor(qw(green blue) [$_ % 2]);\n    $img->turn(-45);\n    $img->line($nr);\n    $img->line($nr);\n    $img->line($nr);\n    $img->line($nr);\n    $img->fgcolor('black');\n    $img->turn(45);\n    $img->line($nr + $_);\n    $img->fgcolor('purple');\n    $img->turn(-45);\n    $img->line(-$nr);\n    $img->line(-$nr);\n}\n\nmy $image_name = 'trizen_flat_logo.png';\n\nopen my $fh, '>:raw', $image_name or die $!;\nprint {$fh} $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/trizen_new_logo.pl",
    "content": "#!/usr/bin/perl\n\nuse strict;\nuse warnings;\n\nuse GD::Simple;\n\nmy $img = 'GD::Simple'->new(2000, 2000);\n$img->moveTo(510, 1100);\n\nmy $nr = 308.5;\n\nfor (0 .. 280) {\n\n    $img->fgcolor('green');\n    $img->turn($nr);\n\n    for (1 .. 4) {\n        $img->line(-$nr);\n    }\n\n    $img->fgcolor('gray');\n    $img->turn(-$nr);\n\n    for (1 .. 4) {\n        $img->line($nr);\n    }\n\n    $img->fgcolor('blue');\n    $img->line($nr);\n\n    $img->fgcolor('purple');\n    $img->turn($nr);\n    $img->line(-$nr);\n\n    $img->fgcolor('red');\n    $img->line(-$nr);\n}\n\nmy $image_name = 'trizen_new_logo.png';\n\nopen my $fh, '>:raw', $image_name or die $!;\nprint {$fh} $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/trizen_old_logo.pl",
    "content": "#!/usr/bin/perl\n\nuse strict;\nuse warnings;\n\nuse GD::Simple;\n\nmy $img = 'GD::Simple'->new(1000, 1000);\n$img->moveTo(285, 80);\n\nmy $nr = 257;\n\nfor (0 .. 100) {\n    $img->fgcolor('green');\n    $img->turn($nr);\n    $img->line(-$nr);\n    $img->line(-$nr);\n    $img->line(-$nr);\n    $img->line(-$nr);\n    $img->fgcolor('gray');\n    $img->turn(-$nr);\n    $img->line($nr);\n    $img->line($nr);\n    $img->line($nr);\n    $img->line($nr);\n    $img->fgcolor('blue');\n    $img->turn(-$nr);\n    $img->line($nr);\n    $img->fgcolor('purple');\n    $img->turn($nr);\n    $img->line(-$nr);\n    $img->fgcolor('red');\n    $img->turn($nr);\n    $img->line(-$nr);\n}\n\nmy $image_name = 'trizen_old_logo.png';\n\nopen my $fh, '>', $image_name or die $!;\nprint {$fh} $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/trizen_text_art.pl",
    "content": "#!/usr/bin/perl\n\nuse strict;\nuse warnings;\n\nuse GD::Simple;\n\nmy $img = 'GD::Simple'->new(2503, 2500);\n$img->moveTo(540, 1980);\n\nmy $nr = 360;\n\nforeach $_ (0 .. 410) {\n    $img->fgcolor('purple');\n    $img->turn(-90);\n    $img->line(--$nr / 10);\n    $img->turn(90);\n    $img->line($nr);\n    $img->turn(90);\n    $img->line($nr / 10);\n    $img->turn(90);\n    $img->move($nr / 2);\n    $img->turn(90);\n    $img->move($nr / 10);\n    $img->turn(-180);\n    $img->line($nr);\n    $img->turn(-90);\n    $img->fgcolor('green');\n    $img->move($nr / 1.5);\n    $img->turn(-90);\n    $img->line($nr);\n    $img->turn(90);\n    $img->line($nr / 2 - $nr / 10);\n    $img->turn(45);\n    $img->line($nr / 10);\n    $img->turn(45);\n    $img->line($nr / 2 - $nr / 10);\n    $img->turn(45);\n    $img->line($nr / 10);\n    $img->turn(45);\n    $img->line($nr / 2 - $nr / 10);\n    $img->turn(-135);\n    $img->line($nr / 2 + $nr / 4 - $nr / 10);\n    $img->turn(-135);\n    $img->line($nr / 10);\n    $img->turn(180);\n    $img->move($nr / 10);\n    $nr -= $_;\n    $img->fgcolor('black');\n    $img->turn(-90);\n    $img->move($nr / 4);\n    $img->turn(-90);\n    $img->line($nr);\n    $img->move($nr / 10);\n    $img->turn(180);\n    $img->move($nr / 10 + 12 + 6);\n    $img->turn(-90);\n    $img->move($nr / 5);\n    $img->line(12);\n    $img->turn(180);\n    $img->line(-12);\n    $img->line(12);\n    $img->turn(45);\n    $img->line(-12);\n    $img->turn(180);\n    $img->line(12);\n    $img->line(-12);\n    $img->turn(45);\n    $img->line(12);\n    $img->turn(180);\n    $img->line(-12);\n    $img->line(12);\n    $img->turn(45);\n    $img->line(-12);\n    $img->turn(180);\n    $img->line(12);\n    $img->line(-12);\n    $img->turn(45);\n    $img->line(12);\n    $img->turn(180);\n    $img->line(-12);\n    $img->line(12);\n    $img->turn(45);\n    $img->line(-12);\n    $img->turn(180);\n    $img->line(12);\n    $img->line(-12);\n    $img->turn(45);\n    $img->line(12);\n    $img->turn(180);\n    $img->line(-12);\n    $img->line(12);\n    $img->turn(45);\n    $img->line(-12);\n    $img->turn(180);\n    $img->line(12);\n    $img->line(-12);\n    $nr += $_;\n    $img->fgcolor('red');\n    $img->turn(-45);\n    $img->move($nr + 72);\n    $img->turn(-90);\n    $img->move($nr / 7);\n    $img->turn(-65);\n    $img->line($nr + $nr / 10);\n    $img->turn(-115);\n    $img->line($nr / 2);\n    $img->turn(-90);\n    $img->line($nr / 10);\n    $img->turn(180);\n    $img->move($nr / 10);\n    $img->turn(155);\n    $img->move($nr + $nr / 10);\n    $img->turn(-155);\n    $img->line($nr / 10);\n    $img->turn(180);\n    $img->move($nr / 10);\n    $img->turn(90);\n    $img->line($nr / 2 - $nr / 7 / 2);\n    $img->turn(115);\n    $img->move(($nr + $nr / 10) / 2);\n    $img->turn(-115);\n    $img->line($nr / 4);\n    $img->turn(-90);\n    $img->line($nr / 10);\n    $img->turn(180);\n    $img->move($nr / 10);\n    $img->turn(90);\n    $img->line($nr / 2);\n    $img->turn(-90);\n    $img->line($nr / 10);\n    $img->fgcolor('orange');\n    $img->turn(180);\n    $img->move($nr / 2 + $nr / 10);\n    $img->turn(-90);\n    $img->move($nr / 5);\n    $img->turn(-90);\n    $img->line($nr);\n    $img->turn(90);\n    $img->line($nr / 2);\n    $img->turn(90);\n    $img->move($nr / 2);\n    $img->turn(90);\n    $img->line($nr / 2);\n    $img->turn(-90);\n    $img->move($nr / 2);\n    $img->line($nr / 2);\n    $img->fgcolor('blue');\n    $img->turn(0);\n    $img->move($nr / 4);\n    $img->turn(-90);\n    $img->line($nr);\n    $img->turn(155);\n    $img->line($nr + $nr / 10);\n    $img->turn(-155);\n    $img->line($nr);\n}\n\nmy $image_name = 'trizen_text_art.png';\n\nopen my $fh, '>:raw', $image_name or die $!;\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/tupper_s_self-referential_formula.pl",
    "content": "#!/usr/bin/perl\n\n# Tupper's self-referential formula.\n\n# Plot the inequality:\n#   1/2 < floor(mod(floor(y/17)*2^(-17*floor(x)-mod(floor(y), 17)),2))\n\n# See also:\n#   https://www.youtube.com/watch?v=_s5RFgd59ao\n#   https://en.wikipedia.org/wiki/Tupper's_self-referential_formula\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager;\nuse Math::AnyNum qw(PREC 2048 :overload floor mod);\n\nmy $red = Imager::Color->new('#ff0000');\n\nmy $img = Imager->new(xsize => 111,\n                      ysize => 17);\n\nmy $k = Math::AnyNum->new('960939379918958884971672962127852754715004339660129306651505519271702802395266424689642842174350718121267153782770623355993237280874144307891325963941337723487857735749823926629715517173716995165232890538221612403238855866184013235585136048828693337902491454229288667081096184496091705183454067827731551705405381627380967602565625016981482083418783163849115590225610003652351370343874461848378737238198224849863465033159410054974700593138339226497249461751545728366702369745461014655997933798537483143786841806593422227898388722980000748404719');\n\nforeach my $x (0 .. 110) {\n    foreach my $y (0 .. 16) {\n        if (1/2 < floor(mod(exp(log(floor(($y + $k) / 17)) + log(2) * (-17 * $x - mod($y + $k, 17))), 2))) {\n            $img->setpixel(x => '110' - $x - '2', y => $y, color => $red);\n        }\n    }\n}\n\n$img->write(file => 'tupper_formula.png');\n"
  },
  {
    "path": "GD/wavy_triangle.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 26 May 2015\n# https://github.com/trizen\n\n#\n## Generate a wavy triangle using the power of 2.5 (scaled down by a trivial constant)\n#\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse GD::Simple;\n\nsub generate {\n    my ($n, $data) = @_;\n\n    for my $i (0 .. $n) {\n        $data->{int(($i**2.5) / 12000)} = 1;\n    }\n\n    return $n;\n}\n\nsay \"** Generating...\";\n\nmy %data;\nmy $max = generate(500000, \\%data);\nmy $limit = int(sqrt($max)) - 1;\n\n# create a new image\nmy $img = GD::Simple->new($limit * 2, $limit + 1);\n\nmy $i = 1;\nmy $j = 1;\n\nmy $black = 0;\nfor my $m (reverse(0 .. $limit)) {\n    $img->moveTo($m, $i - 1);\n\n    for my $n ($j .. $i**2) {\n        if (exists $data{$j}) {\n            $black = 0;\n            $img->fgcolor('red');\n        }\n        elsif (not $black) {\n            $black = 1;\n            $img->fgcolor('black');\n        }\n        $img->line(1);\n        ++$j;\n    }\n    ++$i;\n}\n\nopen my $fh, '>:raw', 'wavy_triangle.png';\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GD/zeta_real_half_terms.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 08 August 2017\n# https://github.com/trizen\n\n# Plotting of the terms in the series:\n#\n#   zeta(1/2 + s*i) = Sum_{n>=1} 1/(n^(1/2 + s*i))\n#\n\n# where we have the identity:\n#   1/(n^(1/2 + s*i)) = (cos(log(n) * s) - i*sin(log(n) * s)) / sqrt(n)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager;\n\nmy $red = Imager::Color->new('#ff0000');\n\nmy $size = 1000;\nmy $img = Imager->new(xsize => $size,\n                      ysize => $size);\n\nmy $s = 14.134725142;\n\nforeach my $n (1 .. 3000) {\n\n    my ($x, $y) = (\n         cos(log($n) * $s) / sqrt($n),\n        -sin(log($n) * $s) / sqrt($n),\n    );\n\n    $img->setpixel(\n                   x     => ($size / 2 + $size / 2 * $x),\n                   y     => ($size / 2 + $size / 2 * $y),\n                   color => $red,\n                  );\n}\n\n$img->write(file => 'zeta_real_half.png');\n"
  },
  {
    "path": "GD/zig-zag_primes.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 11 April 2015\n# https://github.com/trizen\n\n# A zig-zag matrix with the primes highlighted in blue\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse GD::Simple;\nuse ntheory qw(is_prime);\n\nsub zig_zag {\n    my ($w, $h) = @_;\n\n    #\n    ## Code from: https://rosettacode.org/wiki/Zig-zag_matrix#Perl\n    #\n\n    my (@r, $n);\n    $r[$_->[1]][$_->[0]] = $n++\n      for\n      sort { $a->[0] + $a->[1] <=> $b->[0] + $b->[1] or ($a->[0] + $a->[1]) % 2 ? $a->[1] <=> $b->[1] : $a->[0] <=> $b->[0] }\n      map {\n        my $e = $_;\n        map { [$e, $_] } 0 .. $w - 1\n      } 0 .. $h - 1;\n\n    return \\@r;\n}\n\nmy $x = 1000;\nmy $y = 1000;\n\nmy $matrix = zig_zag($x, $y);\n\n# create a new image\nmy $img = GD::Simple->new($x, $y);\n\nmy $white = 1;\n$img->fgcolor('white');\n\nforeach my $i (0 .. $x - 1) {\n    $img->moveTo(0, $i);\n    foreach my $j (0 .. $y - 1) {\n        if (is_prime($matrix->[$i][$j])) {\n            if ($white) {\n                $img->fgcolor('blue');\n                $white = 0;\n            }\n        }\n        elsif (not $white) {\n            $img->fgcolor('white');\n            $white = 1;\n        }\n        $img->line(1);\n    }\n}\n\nopen my $fh, '>:raw', 'zig-zag_primes.png';\nprint $fh $img->png;\nclose $fh;\n"
  },
  {
    "path": "GTK+/mouse_position.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 14 November 2017\n# https://github.com/trizen\n\n# Get the current location of the mouse cursor.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Gtk2 ('-init');\n\nmy (undef, $x, $y) = 'Gtk2::Window'->new->get_screen->get_display->get_pointer;\n\nsay \"x=$x y=$y\";\n"
  },
  {
    "path": "GTK+/tray-file-browser.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 15 May 2014\n# https://github.com/trizen\n\n# A simple Gtk2 tray applet file browser - first release.\n\nuse utf8;\nuse 5.016;\nuse strict;\nuse warnings;\n\nuse Gtk2 qw(-init);\nuse File::Spec::Functions qw(catfile);\n\nmy $dir = defined $ARGV[0] && -d $ARGV[0]    # start dir\n    ? $ARGV[0]\n    : $ENV{HOME};\nmy $cmd = 'pcmanfm';                         # command to open files with\n\n# Add content of a directory as a submenu for an item\nsub create_submenu {\n    my ($item, $abs_path) = @_;\n\n    # Create a new menu\n    my $menu = 'Gtk2::Menu'->new;\n\n    # Append 'Browser here...'\n    my $browse_here = 'Gtk2::ImageMenuItem'->new(\"Browse here...\");\n    $browse_here->signal_connect('activate' => sub { system \"$cmd \\Q$abs_path\\E &\" });\n    $menu->append($browse_here);\n\n    # Append an horizontal separator\n    $menu->append('Gtk2::SeparatorMenuItem'->new);\n\n    # Add the dir content in this new menu\n    add_content($menu, $abs_path);\n\n    # Set submenu for item to this new menu\n    $item->set_submenu($menu);\n\n    # Make menu content visible\n    $menu->show_all;\n}\n\n# Append a directory to a submenu\nsub append_dir {\n    my ($submenu, $dirname, $abs_path) = @_;\n\n    # Create the dir submenu\n    my $dirmenu = 'Gtk2::Menu'->new;\n\n    # Create a new menu item\n    my $item = 'Gtk2::ImageMenuItem'->new($dirname);\n\n    # Set icon\n    $item->set_image('Gtk2::Image'->new_from_icon_name('inode-directory', 'menu'));\n\n    # Set a signal (activates on click)\n    $item->signal_connect('activate' => sub { create_submenu($item, $abs_path) });\n\n    # Set the submenu to the entry item\n    $item->set_submenu($dirmenu);\n\n    # Append the item to the submenu\n    $submenu->append($item);\n}\n\n# Append a file to a submenu\nsub append_file {\n    my ($submenu, $filename, $abs_path) = @_;\n\n    # Create a new menu item\n    my $item = Gtk2::ImageMenuItem->new($filename);\n\n    # Set icon\n    $item->set_image('Gtk2::Image'->new_from_icon_name('gtk-file', 'menu'));\n\n    # Set a signal (activates on click)\n    $item->signal_connect('activate' => sub { system \"$cmd \\Q$abs_path\\E &\" });\n\n    # Append the item to the submenu\n    $submenu->append($item);\n}\n\n# Read a content directory and add it to a submenu\nsub add_content {\n    my ($submenu, $dir) = @_;\n\n    my (@dirs, @files);\n    opendir(my $dir_h, $dir) or return;\n    while (defined(my $filename = readdir($dir_h))) {\n\n        # Ignore hidden files\n        next if chr ord $filename eq '.';\n\n        # Join directory with filename\n        -r (my $abs_path = catfile($dir, $filename)) or next;\n\n        # UTF-8 decode the filename shown in menu\n        utf8::decode($filename);\n\n        # Collect the files and dirs\n        push @{(-d _) ? \\@dirs : \\@files}, [$filename =~ s/_/__/gr, $abs_path];\n    }\n    closedir $dir_h;\n\n    my @calls = ([\\&append_file => \\@files], [\\&append_dir => \\@dirs]);\n    foreach my $call (1 ? reverse(@calls) : @calls) {\n        $call->[0]->($submenu, $_->[0], $_->[1]) for sort { fc($a->[0]) cmp fc($b->[0]) } @{$call->[1]};\n    }\n\n    return 1;\n}\n\n# Create the main menu and populate it with the content of $dir\nsub create_main_menu {\n    my ($icon, $dir) = @_;\n\n    my $menu = 'Gtk2::Menu'->new;\n    add_content($menu, $dir);\n    $menu->show_all;\n    $menu->popup(undef, undef, sub { Gtk2::StatusIcon::position_menu($menu, 0, 0, $icon) }, [1, 1], 0, 0);\n\n    return 1;\n}\n\n#\n## Main menu\n#\n\nmy $icon = 'Gtk2::StatusIcon'->new;\n$icon->set_from_icon_name('file-manager');\n$icon->set_visible(1);\n$icon->signal_connect('button-release-event' => sub { create_main_menu($icon, $dir) });\n\n'Gtk2'->main;\n"
  },
  {
    "path": "Game solvers/asciiplanes-player-v2.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 27 April 2023\n# https://github.com/trizen\n\n# Solver for the asciiplanes game.\n#\n# The solver maintains an \"info board\" recording what the opponent has told us\n# (air/hit/head) and a \"play board\" representing the solver's current hypothesis\n# about where the remaining planes are.  Each turn it picks the best cell to\n# probe, asks the opponent (or the simulator) for a score, updates both boards,\n# and repeats until all planes are destroyed.\n\nuse utf8;\nuse 5.036;\n\nuse Text::ASCIITable;\nuse Getopt::Long qw(GetOptions);\nuse List::Util   qw(any all shuffle max sum zip);\n\nbinmode(STDOUT, ':utf8');\n\n## Package variables\nmy $pkgname = 'asciiplanes-player';\nmy $version = 0.02;\n\nuse constant {\n              AIR   => '`',    # cell that is known to be empty sky\n              BLANK => ' ',    # cell not yet probed / not yet placed\n              HIT   => 'O',    # cell that is part of a plane body\n              HEAD  => 'X',    # cell that is the nose (head) of a plane\n             };\n\nmy %score_table = (\n                   air  => AIR,\n                   head => HEAD,\n                   hit  => HIT,\n                  );\n\n# ---------------------------------------------------------------------------\n# Runtime configuration (may be overridden by command-line options)\n# ---------------------------------------------------------------------------\n\nmy $BOARD_SIZE = 8;\nmy $PLANES_NUM = 3;\nmy $wrap_plane = 0;\nmy $simulate   = 0;\nmy $hit_char   = HIT;\nmy $miss_char  = AIR;\nmy $head_char  = HEAD;\nmy $seed       = 0;\nmy $use_colors = eval { require Term::ANSIColor; 1; };\n\n## CLI Argument Parsing\nif (@ARGV) {\n    GetOptions(\n               'board-size|size=i' => \\$BOARD_SIZE,\n               'planes-num=i'      => \\$PLANES_NUM,\n               'head-char=s'       => \\$head_char,\n               'hit-char=s'        => \\$hit_char,\n               'miss-char=s'       => \\$miss_char,\n               'wrap!'             => \\$wrap_plane,\n               'simulate!'         => \\$simulate,\n               'colors!'           => \\$use_colors,\n               'seed=i'            => \\$seed,\n               'help|h|?'          => \\&usage,\n               'version|v'         => \\&version,\n              )\n      or die(\"$0: error in command line arguments!\\n\");\n}\n\nsrand($seed) if $seed;\n\n## Plane Direction Shapes (Coordinate Offsets)\nmy @DIRECTIONS = (\n\n    # UP\n    [[0, 0], [1, -1], [1, 0], [1, 1], [2, 0], [3, -1], [3, 0], [3, 1]],\n\n    # DOWN\n    [[-3, -1], [-3, 0], [-3, 1], [-2, 0], [-1, -1], [-1, 0], [-1, 1], [0, 0]],\n\n    # LEFT\n    [[-1, 1], [-1, 3], [0, 0], [0, 1], [0, 2], [0, 3], [1, 1], [1, 3]],\n\n    # RIGHT\n    [[-1, -3], [-1, -1], [0, -3], [0, -2], [0, -1], [0, 0], [1, -3], [1, -1]]\n);\n\nmy $TOTAL_CELLS = $BOARD_SIZE * $BOARD_SIZE;\n\n## Mapping Utilities\nmy %letters2indices;\nmy %indices2letters;\n{\n    my $char = 'a';\n    for my $i (0 .. $BOARD_SIZE - 1) {\n        $letters2indices{$char} = $i;\n        $indices2letters{$i}    = $char;\n        $char++;\n    }\n}\n\n## --- Ahead-of-Time Precomputation ---\n# Precompute valid plane indices for every cell and direction.\n# $PRECOMPUTED_PLANES->[$pos][$dir] = [ idx1, idx2, ... ] or undef\n\nmy $PRECOMPUTED_PLANES = [];\n\nsub init_planes {\n    for my $x (0 .. $BOARD_SIZE - 1) {\n        for my $y (0 .. $BOARD_SIZE - 1) {\n            my $pos = $x * $BOARD_SIZE + $y;\n\n            for my $dir (0 .. $#DIRECTIONS) {\n                my @indices;\n                my $valid = 1;\n\n                for my $offset (@{$DIRECTIONS[$dir]}) {\n                    my $nx = $x + $offset->[0];\n                    my $ny = $y + $offset->[1];\n\n                    if ($wrap_plane) {\n                        $nx %= $BOARD_SIZE;\n                        $ny %= $BOARD_SIZE;\n                    }\n                    elsif ($nx < 0 || $nx >= $BOARD_SIZE || $ny < 0 || $ny >= $BOARD_SIZE) {\n                        $valid = 0;\n                        last;\n                    }\n                    push @indices, $nx * $BOARD_SIZE + $ny;\n                }\n                $PRECOMPUTED_PLANES->[$pos][$dir] = $valid ? \\@indices : undef;\n            }\n        }\n    }\n}\n\ninit_planes();\n\n## --- Core Game Logic (1D Arrays) ---\n\nsub make_play_board {\n    return [(BLANK) x $TOTAL_CELLS];\n}\n\nsub assign ($board, $pos, $dir, $force = 0) {\n    my $indices = $PRECOMPUTED_PLANES->[$pos][$dir] or return;\n\n    if (!$force) {\n        for my $idx (@$indices) {\n            return unless $board->[$idx] eq BLANK;\n        }\n    }\n\n    $board->[$_]   = HIT for @$indices;\n    $board->[$pos] = HEAD;\n    return 1;\n}\n\nsub valid_assignment ($play_board, $info_board, $extra = 0) {\n    for my $i (0 .. $TOTAL_CELLS - 1) {\n        my $info = $info_board->[$i];\n        if ($info eq AIR) {\n            return 0 if $play_board->[$i] ne BLANK;\n        }\n        elsif ($extra && $info ne BLANK) {\n            return 0 if $info ne $play_board->[$i];\n        }\n    }\n    return 1;\n}\n\nsub create_planes ($play_board) {\n    my $count     = 0;\n    my $max_tries = $BOARD_SIZE**4;\n\n    while ($count != $PLANES_NUM) {\n        die \"FATAL ERROR: try to increase the size of the grid (--size=x).\\n\" if --$max_tries <= 0;\n\n        my $pos = int rand($TOTAL_CELLS);\n        my $dir = int rand(4);\n        ++$count if assign($play_board, $pos, $dir);\n    }\n    return 1;\n}\n\nsub guess ($info_board, $play_board, $plane_count) {\n    my $count     = 0;\n    my $max_tries = $TOTAL_CELLS;\n    my @indices   = shuffle(0 .. $TOTAL_CELLS - 1);\n\n    while ($count != ($PLANES_NUM - $plane_count)) {\n        my $pos;\n        while (@indices) {\n            $pos = pop @indices;\n            last if $play_board->[$pos] eq BLANK && $info_board->[$pos] eq BLANK;\n            undef $pos;\n        }\n        return unless defined $pos;\n        return if --$max_tries <= 0;\n\n        my @good_dirs;\n        for my $dir (0 .. 3) {\n            my $indices = $PRECOMPUTED_PLANES->[$pos][$dir];\n            push @good_dirs, $dir if $indices && all { $info_board->[$_] ne AIR } @$indices;\n        }\n\n        ++$count if any { assign($play_board, $pos, $_) } shuffle(@good_dirs);\n    }\n    return 1;\n}\n\nsub get_head_positions ($board) {\n    my @headshots;\n    push @headshots, $_ for grep { $board->[$_] eq HEAD } 0 .. $TOTAL_CELLS - 1;\n    return @headshots;\n}\n\nsub make_play_boards ($info_board) {\n    my @headshots = get_head_positions($info_board);\n    my @boards    = ([make_play_board(), 0]);\n\n    for my $pos (@headshots) {\n        for my $dir (0 .. 3) {\n            for my $board_entry (map { [[@{$_->[0]}], $_->[1]] } @boards) {\n                next unless assign($board_entry->[0], $pos, $dir);\n                push @boards, [$board_entry->[0], $board_entry->[1] + 1];\n            }\n        }\n    }\n\n    my $max_count = max(0, map { $_->[1] } @boards);\n    return grep { valid_assignment($_->[0], $info_board) }\n      grep { $_->[1] == $max_count } @boards;\n}\n\n## --- Solver Heuristics ---\n\nsub _sort_by_center_distance (@positions) {\n    my $center = ($BOARD_SIZE - 1) / 2;\n    return map { $_->[0] }\n      sort { $a->[1] <=> $b->[1] }\n      map {\n        my $x = int($_ / $BOARD_SIZE);\n        my $y = $_ % $BOARD_SIZE;\n        [$_, ($center - $x)**2 + ($center - $y)**2]\n      } @positions;\n}\n\nsub _score_and_sort_by_hits ($info_board, @positions) {\n    my @scored;\n\n    for my $pos (@positions) {\n        next unless $info_board->[$pos] eq BLANK;\n\n        my @valid_planes;\n        for my $dir (0 .. 3) {\n            my $indices = $PRECOMPUTED_PLANES->[$pos][$dir];\n            push @valid_planes, $indices if $indices && all { $info_board->[$_] ne AIR } @$indices;\n        }\n\n        if (@valid_planes) {\n            my $hits = sum(\n                0,\n                map {\n                    scalar grep { $info_board->[$_] eq HIT } @$_\n                  } @valid_planes\n            );\n            push @scored, [$pos, $hits];\n        }\n    }\n\n    return map { $_->[0] } sort { $b->[1] <=> $a->[1] } @scored;\n}\n\nsub solve ($callback) {\n    my $tries      = 0;\n    my $info_board = make_play_board();\n    my @boards     = make_play_boards($info_board);\n\n    while (1) {\n        for my $board_entry (@boards) {\n            my ($board, $plane_count) = @$board_entry;\n            my $play_board = [@$board];    # Native ultra-fast shallow copy\n\n            next unless guess($info_board, $play_board, $plane_count);\n            next unless valid_assignment($play_board, $info_board, 1);\n\n            my @head_pos = _sort_by_center_distance(get_head_positions($play_board));\n            @head_pos = _score_and_sort_by_hits($info_board, @head_pos);\n\n            my $all_dead = 1;\n            my $new_info = 0;\n\n            for my $pos (@head_pos) {\n                next if $info_board->[$pos] ne BLANK;\n\n                $all_dead = 0;\n                my $score = $callback->($pos, $play_board, $info_board) // return;\n                $score = AIR if $score eq BLANK;\n\n                ++$tries;\n                $info_board->[$pos] = $score;\n\n                if ($score eq HEAD) {\n                    $new_info = 1;\n                    @boards   = make_play_boards($info_board);\n                    next;\n                }\n                elsif ($score eq AIR) {\n                    $new_info = 1;\n                    @boards   = reverse(grep { valid_assignment($_->[0], $info_board) } @boards);\n                }\n                last;\n            }\n\n            return $tries if $all_dead;\n            last          if $new_info;\n        }\n    }\n}\n\n## --- IO and Main Execution ---\n\nsub print_ascii_table (@boards) {\n    my @ascii_tables;\n\n    for my $board (@boards) {\n        my $table = Text::ASCIITable->new({headingText => \"$pkgname $version\"});\n        $table->setCols(' ', 1 .. $BOARD_SIZE);\n\n        my $char = 'a';\n        for my $x (0 .. $BOARD_SIZE - 1) {\n\n            # Extract 2D row from 1D board\n            my @row = @{$board}[$x * $BOARD_SIZE .. ($x + 1) * $BOARD_SIZE - 1];\n            $table->addRow([$char++, @row]);\n            $table->addRowLine();\n        }\n\n        my $t = $table->drawit;\n\n        if ($use_colors) {\n            my $hit_color  = Term::ANSIColor::colored($hit_char,  \"bold red\");\n            my $miss_color = Term::ANSIColor::colored($miss_char, \"yellow\");\n            my $head_color = Term::ANSIColor::colored($head_char, \"bold green\");\n\n            $t =~ s{\\Q$hit_char\\E}{$hit_color}g;\n            $t =~ s{\\Q$miss_char\\E}{$miss_color}g;\n            $t =~ s{\\Q$head_char\\E}{$head_color}g;\n        }\n\n        push @ascii_tables, [split(/\\n/, $t)];\n    }\n\n    for my $row (zip(@ascii_tables)) {\n        say join('  ', @$row);\n    }\n}\n\nsub process_user_input ($pos, $play_board, $info_board) {\n\n    require Term::ReadLine;\n    state $term = Term::ReadLine->new(\"ASCII Planes Player\");\n\n    my $i = int($pos / $BOARD_SIZE);\n    my $j = $pos % $BOARD_SIZE;\n\n    print_ascii_table($play_board, $info_board);\n\n    while (1) {\n        say \"=> My guess: \" . join('', $indices2letters{$i}, $j + 1);\n        say \"=> Score (hit, head or air)\";\n\n        my $input = lc($term->readline(\"> \") // return);\n        return if $input eq 'q' or $input eq 'quit';\n\n        $input =~ s/^\\s+|\\s+\\z//g;\n\n        unless (exists $score_table{$input}) {\n            say \"\\n:: Invalid score...\\n\";\n            next;\n        }\n        return $score_table{$input};\n    }\n}\n\nsub usage {\n    print <<\"EOT\";\nusage: $0 [options]\n\nmain:\n        --size=i    : length side of the board (default: $BOARD_SIZE)\n        --planes=i  : the total number of planes (default: $PLANES_NUM)\n        --wrap!     : wrap the plane around the play board (default: $wrap_plane)\n        --head=s    : character used for the head of the plane (default: \"$head_char\")\n        --hit=s     : character used when a plane is hit (default: \"$hit_char\")\n        --miss=s    : character used when a plane is missed (default: \"$miss_char\")\n        --colors!   : use ANSI colors (requires Term::ANSIColor) (default: $use_colors)\n        --simulate! : run a random simulation (default: $simulate)\n        --seed=i    : run with a given pseudorandom seed value > 0 (default: $seed)\n\nhelp:\n        --help      : print this message and exit\n        --version   : print the version number and exit\n\nexample:\n        $0 --size=12 --planes=6 --hit='*'\n\nEOT\n    exit;\n}\n\nsub version {\n    print \"$pkgname $version\\n\";\n    exit;\n}\n\nif ($simulate) {\n\n    # Simulation mode: place planes randomly, then let the solver probe them.\n    my $board = make_play_board();\n    create_planes($board);\n\n    my $tries = solve(\n        sub ($pos, $play_board, $info_board) {\n            print_ascii_table($play_board, $info_board);\n            $board->[$pos];\n        }\n    );\n\n    say \"It took $tries tries to solve:\";\n    print_ascii_table($board);\n}\nelse {\n    # Interactive mode: ask the human to score each probe.\n    my $tries = solve(\\&process_user_input);\n    say \"\\n:: All planes destroyed in $tries tries!\\n\" if defined($tries);\n}\n"
  },
  {
    "path": "Game solvers/asciiplanes-player.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 27 April 2023\n# https://github.com/trizen\n\n# Solver for the asciiplanes game.\n#\n# The solver maintains an \"info board\" recording what the opponent has told us\n# (air/hit/head) and a \"play board\" representing the solver's current hypothesis\n# about where the remaining planes are.  Each turn it picks the best cell to\n# probe, asks the opponent (or the simulator) for a score, updates both boards,\n# and repeats until all planes are destroyed.\n\nuse utf8;\nuse 5.036;\n\nuse Text::ASCIITable;\nuse List::Util qw(any all shuffle max sum zip);\nuse Getopt::Long;\n\nbinmode(STDOUT, ':utf8');\n\n## Package variables\nmy $pkgname = 'asciiplanes-player';\nmy $version = 0.01;\n\nuse constant {\n              AIR   => '`',    # cell that is known to be empty sky\n              BLANK => ' ',    # cell not yet probed / not yet placed\n              HIT   => 'O',    # cell that is part of a plane body\n              HEAD  => 'X',    # cell that is the nose (head) of a plane\n             };\n\nmy %score_table = (\n                   air  => AIR,\n                   head => HEAD,\n                   hit  => HIT,\n                  );\n\n# ---------------------------------------------------------------------------\n# Runtime configuration (may be overridden by command-line options)\n# ---------------------------------------------------------------------------\n\nmy $BOARD_SIZE = 8;\nmy $PLANES_NUM = 3;\nmy $wrap_plane = 0;\nmy $simulate   = 0;\nmy $hit_char   = HIT;\nmy $miss_char  = AIR;\nmy $head_char  = HEAD;\nmy $seed       = 0;\nmy $use_colors = eval { require Term::ANSIColor; 1; };\n\n## CLI Argument Parsing\nif (@ARGV) {\n    GetOptions(\n               'board-size|size=i' => \\$BOARD_SIZE,\n               'planes-num=i'      => \\$PLANES_NUM,\n               'head-char=s'       => \\$head_char,\n               'hit-char=s'        => \\$hit_char,\n               'miss-char=s'       => \\$miss_char,\n               'wrap!'             => \\$wrap_plane,\n               'simulate!'         => \\$simulate,\n               'colors!'           => \\$use_colors,\n               'seed=i'            => \\$seed,\n               'help|h|?'          => \\&usage,\n               'version|v'         => \\&version,\n              )\n      or die(\"$0: error in command line arguments!\\n\");\n}\n\nsrand($seed) if $seed;\n\n## Plane Direction Shapes\n#<<<\nmy $UP = [\n              [+0, +0],\n    [+1, -1], [+1, +0], [+1, +1],\n              [+2, +0],\n    [+3, -1], [+3, +0], [+3, +1],\n];\n\nmy $DOWN = [\n    [-3, -1], [-3, +0], [-3, +1],\n              [-2, +0],\n    [-1, -1], [-1, +0], [-1, +1],\n              [+0, +0],\n];\n\nmy $LEFT = [\n              [-1, +1],           [-1, +3],\n    [+0, +0], [+0, +1], [+0, +2], [+0, +3],\n              [+1, +1],           [+1, +3],\n];\n\nmy $RIGHT = [\n    [-1, -3],           [-1, -1],\n    [+0, -3], [+0, -2], [+0, -1], [+0, +0],\n    [+1, -3],           [+1, -1],\n];\n#>>>\n\nmy @DIRECTIONS   = ($UP, $DOWN, $LEFT, $RIGHT);\nmy @PAIR_INDICES = map {\n    my $i = $_;\n    map { [$i, $_] } 0 .. $BOARD_SIZE - 1\n} 0 .. $BOARD_SIZE - 1;\n\n## Mapping Utilities\nmy %letters2indices = get_letters();\nmy %indices2letters = reverse %letters2indices;\n\n## --- Core Game Logic ---\n\n# Given a board, a head position (x, y), and a direction (array of offsets),\n# return references to the board cells that the plane would occupy.\n# Returns an empty list if any cell is out of bounds (unless $wrap_plane is set).\nsub pointers ($board, $x, $y, $indices) {\n    my @refs;\n    for my $offset (@$indices) {\n        my ($row, $col) = ($x + $offset->[0], $y + $offset->[1]);\n\n        if ($wrap_plane) {\n            $row %= $BOARD_SIZE;\n            $col %= $BOARD_SIZE;\n        }\n\n        return () if $row < 0 or $row >= $BOARD_SIZE;\n        return () if $col < 0 or $col >= $BOARD_SIZE;\n\n        push @refs, \\$board->[$row][$col];\n    }\n    return @refs;\n}\n\n# Try to place a plane on $board with its head at ($x, $y) facing $dir.\n# All cells must currently be BLANK (unless $force is true).\n# Returns 1 on success, undef on failure.\nsub assign ($board, $dir, $x, $y, $force = 0) {\n    my @plane = pointers($board, $x, $y, $dir);\n    return unless @plane;\n\n    if (!$force) {\n        for my $point (@plane) {\n            return unless $$point eq BLANK;\n        }\n    }\n\n    $$_ = HIT for @plane;\n    $board->[$x][$y] = HEAD;\n    return 1;\n}\n\n# ---------------------------------------------------------------------------\n# Board validation\n# ---------------------------------------------------------------------------\n\n# Return true if $play_board is consistent with $info_board.\n# In strict mode ($extra true), HIT/HEAD cells must also match.\nsub valid_assignment ($play_board, $info_board, $extra = 0) {\n    for my $i (0 .. $BOARD_SIZE - 1) {\n        for my $j (0 .. $BOARD_SIZE - 1) {\n            my $play = $play_board->[$i][$j];\n            my $info = $info_board->[$i][$j];\n\n            if ($info eq AIR) {\n                return 0 if $play ne BLANK;\n            }\n            elsif ($extra && $info ne BLANK) {\n                return 0 if $info ne $play;\n            }\n        }\n    }\n    return 1;\n}\n\n# ---------------------------------------------------------------------------\n# Plane generation (for simulation mode)\n# ---------------------------------------------------------------------------\n\n# Place $PLANES_NUM non-overlapping planes randomly on $play_board.\nsub create_planes ($play_board) {\n    my $count     = 0;\n    my $max_tries = $BOARD_SIZE**4;\n\n    while ($count != $PLANES_NUM) {\n        my $x   = int rand($BOARD_SIZE);\n        my $y   = int rand($BOARD_SIZE);\n        my $dir = $DIRECTIONS[rand @DIRECTIONS];\n\n        die \"FATAL ERROR: try to increase the size of the grid (--size=x).\\n\" if --$max_tries <= 0;\n\n        ++$count if assign($play_board, $dir, $x, $y);\n    }\n    return 1;\n}\n\n# Speculatively fill $play_board with the remaining unconfirmed planes,\n# trying random blank positions and directions compatible with $info_board.\nsub guess ($info_board, $play_board, $plane_count) {\n    my $count     = 0;\n    my $max_tries = $BOARD_SIZE * $BOARD_SIZE;\n    my @indices   = shuffle(@PAIR_INDICES);\n\n    while ($count != ($PLANES_NUM - $plane_count)) {\n        my ($x, $y);\n\n        while (@indices) {\n            ($x, $y) = @{pop(@indices)};\n            last if $play_board->[$x][$y] eq BLANK && $info_board->[$x][$y] eq BLANK;\n            undef $x;\n        }\n        return unless defined $x;\n        return if --$max_tries <= 0;\n\n        my @good_directions = grep {\n            my @plane = pointers($info_board, $x, $y, $_);\n            @plane && all { $$_ ne AIR } @plane;\n        } @DIRECTIONS;\n\n        ++$count if any { assign($play_board, $_, $x, $y) } shuffle(@good_directions);\n    }\n    return 1;\n}\n\n# Return a list of [row, col] pairs for every HEAD cell on the board.\nsub get_head_positions ($board) {\n    my @headshots;\n    for my $i (0 .. $#{$board}) {\n        for my $j (0 .. $#{$board->[$i]}) {\n            push @headshots, [$i, $j] if $board->[$i][$j] eq HEAD;\n        }\n    }\n    return @headshots;\n}\n\nsub make_play_board {\n    [map { [(BLANK) x $BOARD_SIZE] } 1 .. $BOARD_SIZE];\n}\n\nsub clone_board ($board) {\n    [map { [@$_] } @$board];\n}\n\n# ---------------------------------------------------------------------------\n# Hypothesis management\n# ---------------------------------------------------------------------------\n\n# Build all possible board configurations consistent with $info_board,\n# anchoring any confirmed HEAD positions from the info board.\nsub make_play_boards ($info_board) {\n    my @headshots = get_head_positions($info_board);\n    my @boards    = ([make_play_board(), 0]);\n\n    for my $pos (@headshots) {\n        for my $dir (@DIRECTIONS) {\n            for my $board (map { [clone_board($_->[0]), $_->[1]] } @boards) {\n                next unless assign($board->[0], $dir, $pos->[0], $pos->[1]);\n                push @boards, [$board->[0], $board->[1] + 1];\n            }\n        }\n    }\n\n    my $max_count = max(map { $_->[1] } @boards);\n    return grep { valid_assignment($_->[0], $info_board) }\n      grep { $_->[1] == $max_count } @boards;\n}\n\n## --- Solver Heuristics ---\n\n# Sort HEAD positions: descending by number of HIT cells in viable directions\n# (prefer planes with the most confirmed body cells), then ascending by\n# distance from board centre (prefer central cells as a tiebreaker).\nsub _sort_by_center_distance (@head_positions) {\n    my $center = ($BOARD_SIZE - 1) / 2;\n    return map { $_->[0] }\n      sort { $a->[1] <=> $b->[1] }\n      map {\n        my ($x, $y) = @$_;\n        [$_, ($center - $x)**2 + ($center - $y)**2]\n      } @head_positions;\n}\n\n# Annotate each HEAD position with the directions still viable from it\n# (no AIR cell in the way) and the number of HIT cells they collectively cover.\nsub _score_and_sort_by_hits ($info_board, @head_positions) {\n    my @scored;\n\n    for my $pos (@head_positions) {\n        my ($x, $y) = @$pos;\n        next unless $info_board->[$x][$y] eq BLANK;\n\n        my @valid_planes;\n        for my $dir (@DIRECTIONS) {\n            my @plane = pointers($info_board, $x, $y, $dir);\n            push @valid_planes, \\@plane if @plane && all { $$_ ne AIR } @plane;\n        }\n\n        if (@valid_planes) {\n            my $hits = sum(\n                0,\n                map {\n                    scalar grep { $$_ eq HIT }\n                      @$_\n                  } @valid_planes\n            );\n            push @scored, [$pos, $hits];\n        }\n    }\n\n    return map { $_->[0] } sort { $b->[1] <=> $a->[1] } @scored;\n}\n\n# ---------------------------------------------------------------------------\n# Main solver loop\n# ---------------------------------------------------------------------------\n\n# Drive the solving process.  For each turn, pick the best cell to probe and\n# invoke $callback->($row, $col, $play_board, $info_board).\n# The callback returns the score (AIR/HIT/HEAD) or undef to abort.\n# Returns the total number of probes on success.\nsub solve ($callback) {\n    my $tries      = 0;\n    my $info_board = make_play_board();\n    my @boards     = make_play_boards($info_board);\n\n    while (1) {\n        for my $board_entry (@boards) {\n            my ($board, $plane_count) = @$board_entry;\n\n            # Build a full speculative board from this hypothesis.\n            my $play_board = clone_board($board);\n\n            next unless guess($info_board, $play_board, $plane_count);\n            next unless valid_assignment($play_board, $info_board, 1);\n\n            # Apply Heuristics: Center proximity first, then filter and rank by potential hits\n            my @head_pos = _sort_by_center_distance(get_head_positions($play_board));\n            @head_pos = _score_and_sort_by_hits($info_board, @head_pos);\n\n            my $all_dead = 1;\n            my $new_info = 0;\n\n            for my $pos (@head_pos) {\n                my ($i, $j) = @$pos;\n                next if $info_board->[$i][$j] ne BLANK;\n\n                $all_dead = 0;\n\n                # Ask the human (or simulator) for the result of probing this cell.\n                my $score = $callback->($i, $j, $play_board, $info_board) // return;\n                $score = AIR if $score eq BLANK;\n\n                ++$tries;\n                $info_board->[$i][$j] = $score;\n\n                if ($score eq HEAD) {\n\n                    # A confirmed head -- rebuild all hypotheses.\n                    $new_info = 1;\n                    @boards   = make_play_boards($info_board);\n                    next;\n                }\n                elsif ($score eq AIR) {\n\n                    # A miss -- prune inconsistent hypotheses.\n                    $new_info = 1;\n                    @boards   = reverse(grep { valid_assignment($_->[0], $info_board) } @boards);\n                }\n                last;\n            }\n\n            return $tries if $all_dead;\n            last          if $new_info;\n        }\n    }\n}\n\n## --- IO and Main Execution ---\n\nsub get_letters {\n    my %letters;\n    my $char = 'a';\n    $letters{$char++} = $_ for 0 .. $BOARD_SIZE - 1;\n    return %letters;\n}\n\n# Print one or more boards side by side.\nsub print_ascii_table (@boards) {\n    my @ascii_tables;\n\n    for my $board (@boards) {\n        my $table = Text::ASCIITable->new({headingText => \"$pkgname $version\"});\n        $table->setCols(' ', 1 .. $BOARD_SIZE);\n\n        my $char = 'a';\n        for my $row (@$board) {\n            $table->addRow([$char++, @$row]);\n            $table->addRowLine();\n        }\n\n        my $t = $table->drawit;\n\n        if ($use_colors) {\n            my $hit_color  = Term::ANSIColor::colored($hit_char,  \"bold red\");\n            my $miss_color = Term::ANSIColor::colored($miss_char, \"yellow\");\n            my $head_color = Term::ANSIColor::colored($head_char, \"bold green\");\n\n            $t =~ s{\\Q$hit_char\\E}{$hit_color}g;\n            $t =~ s{\\Q$miss_char\\E}{$miss_color}g;\n            $t =~ s{\\Q$head_char\\E}{$head_color}g;\n        }\n\n        push @ascii_tables, [split(/\\n/, $t)];\n    }\n\n    for my $row (zip(@ascii_tables)) {\n        say join('  ', @$row);\n    }\n}\n\n# ---------------------------------------------------------------------------\n# Interactive mode\n# ---------------------------------------------------------------------------\n\nsub process_user_input ($i, $j, $play_board, $info_board) {\n\n    require Term::ReadLine;\n    state $term = Term::ReadLine->new(\"ASCII Planes Player\");\n\n    print_ascii_table($play_board, $info_board);\n\n    while (1) {\n        say \"=> My guess: \" . join('', $indices2letters{$i}, $j + 1);\n        say \"=> Score (hit, head or air)\";\n\n        my $input = lc($term->readline(\"> \") // return);\n        return if $input eq 'q' or $input eq 'quit';\n\n        $input =~ s/^\\s+|\\s+\\z//g;\n\n        unless (exists $score_table{$input}) {\n            say \"\\n:: Invalid score...\\n\";\n            next;\n        }\n        return $score_table{$input};\n    }\n}\n\nsub usage {\n    print <<\"EOT\";\nusage: $0 [options]\n\nmain:\n        --size=i    : length side of the board (default: $BOARD_SIZE)\n        --planes=i  : the total number of planes (default: $PLANES_NUM)\n        --wrap!     : wrap the plane around the play board (default: $wrap_plane)\n        --head=s    : character used for the head of the plane (default: \"$head_char\")\n        --hit=s     : character used when a plane is hit (default: \"$hit_char\")\n        --miss=s    : character used when a plane is missed (default: \"$miss_char\")\n        --colors!   : use ANSI colors (requires Term::ANSIColor) (default: $use_colors)\n        --simulate! : run a random simulation (default: $simulate)\n        --seed=i    : run with a given pseudorandom seed value > 0 (default: $seed)\n\nhelp:\n        --help      : print this message and exit\n        --version   : print the version number and exit\n\nexample:\n        $0 --size=12 --planes=6 --hit='*'\n\nEOT\n    exit;\n}\n\nsub version {\n    print \"$pkgname $version\\n\";\n    exit;\n}\n\nif ($simulate) {\n\n    # Simulation mode: place planes randomly, then let the solver probe them.\n    my $board = make_play_board();\n    create_planes($board);\n\n    my $tries = solve(\n        sub ($i, $j, $play_board, $info_board) {\n            print_ascii_table($play_board, $info_board);\n            $board->[$i][$j];\n        }\n    );\n\n    say \"It took $tries tries to solve:\";\n    print_ascii_table($board);\n}\nelse {\n    # Interactive mode: ask the human to score each probe.\n    my $tries = solve(\\&process_user_input);\n    say \"\\n:: All planes destroyed in $tries tries!\\n\" if defined($tries);\n}\n"
  },
  {
    "path": "Game solvers/dice_game_solver.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 20 May 2013\n# https://github.com/trizen\n\n# Dice game solver\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nmy $board = [\n             [4, 1, 3, 3, 5, 2],\n             [3, 4, 1, 2, 0, 3],\n             [5, 1, 5, 5, 4, 2],\n             [1, 3, 2, 5, 2, 1],\n             [6, 2, 4, 1, 5, 4],\n             [6, 2, 1, 6, 6, 3],\n            ];\n\nmy %moves = (\n             'up'         => [-1, +0],\n             'up-right'   => [-1, +1],\n             'up-left'    => [-1, -1],\n             'right'      => [+0, +1],\n             'left'       => [+0, -1],\n             'down'       => [+1, +0],\n             'down-left'  => [+1, -1],\n             'down-right' => [+1, +1],\n            );\n\nmy @directions = keys %moves;\n\nsub valid_move {\n    my ($row, $col) = @_;\n\n    if ($row < 0 or not exists $board->[$row]) {\n        return;\n    }\n\n    if ($col < 0 or not exists $board->[$row][$col]) {\n        return;\n    }\n\n    return 1;\n}\n\nwhile (1) {\n    my %map;\n    my %seen;\n    my @dirs;\n    my %spos;\n\n    my $current_pos = [$#{$board}, 0];\n    my $current_num = $board->[$current_pos->[0]][$current_pos->[1]];\n\n    $spos{join('|', @{$current_pos})}++;\n\n    foreach my $num (1 .. @{$board}**2) {\n\n        my $dir = (\n            exists $map{$current_num}\n            ? $map{$current_num}\n            : do {\n\n                my %table;\n                @table{values %map} = ();\n\n                my $d;\n\n                do {\n                    $d = $directions[rand @directions];\n                } while (exists($table{$d}));\n\n                $d;\n              }\n        );\n\n        my $pos = $moves{$dir};\n        my $row = $current_pos->[0] + $pos->[0];\n        my $col = $current_pos->[1] + $pos->[1];\n\n        valid_move($row, $col) || last;\n        if (++$spos{join('|', $row, $col)} > 1) {\n            last;\n        }\n\n        push @dirs, {dir => $dir, num => $current_num, pos => $current_pos};\n\n        $map{$current_num} //= $dir;\n        $current_pos = [$row, $col];\n        $current_num = $board->[$current_pos->[0]][$current_pos->[1]];\n        $seen{$current_num}++;\n\n        if ($current_num == 0) {\n            if ($seen{$board->[$current_pos->[0] - $pos->[0]][$current_pos->[1] - $pos->[1]]} > 1) {\n                use Data::Dump qw(pp);\n                pp \\@dirs;\n                exit;\n            }\n            last;\n        }\n    }\n}\n"
  },
  {
    "path": "Game solvers/peg-solitaire-solver",
    "content": "#!/usr/bin/perl\n\n# This program solves the (English) peg solitaire\n# Perl translate from Go code (see __END__)\n# Translator: Trizen\n# Date: 27 February 2012\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse utf8;\nbinmode *STDOUT, ':encoding(utf-8)';\n\nmy $N = 11 + 1;    # length of a board row (+1 for \\n)\n\n# The board must be surrounded by 2 illegal fields\n# in each direction so that move() doesn't need to\n# check the board boundaries. Periods represent\n# illegal fields, ● are pegs, and ○ are holes.\nmy @board = unpack(\n    'C*',\n    '...........\n...........\n....●●●....\n....●●●....\n..●●●●●●●..\n..●●●○●●●..\n..●●●●●●●..\n....●●●....\n....●●●....\n...........\n...........\n'\n                  );\n\n# center is the position of the center hole if\n# there is a single one; otherwise it is -1.\nmy $center;\n\n{\n    my $n = 0;\n    for (my $i = 0 ; $i <= $#board ; ++$i) {\n        if (chr $board[$i] eq '○') {\n            $center = $i;\n            $n++;\n            last;\n        }\n    }\n\n    if ($n != 1) {\n        $center = -1;    # no single hole\n    }\n}\n\nmy $moves;               # number of times move is called\n\n# move tests if there is a peg at position pos that\n# can jump over another peg in direction dir. If the\n# move is valid, it is executed and move returns true.\n# Otherwise, move returns false.\nsub move {\n    my ($pos, $dir) = @_;\n    ++$moves;\n    if (chr $board[$pos] eq '●' and chr $board[$pos + $dir] eq '●' and chr $board[$pos + 2 * $dir] eq '○') {\n        $board[$pos]            = ord '○';\n        $board[$pos + $dir]     = ord '○';\n        $board[$pos + 2 * $dir] = ord '●';\n        return 1;\n    }\n    return 0;\n}\n\n# unmove reverts a previously executed valid move.\nsub unmove {\n    my ($pos, $dir) = @_;\n    $board[$pos]            = ord '●';\n    $board[$pos + $dir]     = ord '●';\n    $board[$pos + 2 * $dir] = ord '○';\n    return 1;\n}\n\n# solve tries to find a sequence of moves such that\n# there is only one peg left at the end; if center is\n# >= 0, that last peg must be in the center position.\n# If a solution is found, solve prints the board after\n# each move in a backward fashion (i.e., the last\n# board position is printed first, all the way back to\n# the starting board position).\nsub solve {\n    my ($last, $n);\n\n    foreach my $pos (0 .. $#board) {\n\n        # try each board position\n        if (chr $board[$pos] eq '●') {\n\n            # found a peg\n            foreach my $dir (-1, -$N, +1, +$N) {\n\n                # try each direction\n                if (move($pos, $dir)) {\n\n                    # a valid move was found and executed,\n                    # see if this new board has a solution\n                    if (solve()) {\n                        unmove($pos, $dir);\n                        say map { chr } @board;\n                        return 1;\n                    }\n                    unmove($pos, $dir);\n                }\n            }\n            $last = $pos;\n            $n++;\n        }\n    }\n\n    # tried each possible move\n    if ($n == 1 && ($center < 0 || $last == $center)) {\n\n        # there's only one peg left\n        say map { chr } @board;\n        return 1;\n    }\n\n    # no solution found for this board\n    return 0;\n}\n\nif (!solve()) {\n    say \"no solution found\";\n}\n\nsay \"$moves moves tried\";\n\n__END__\n// This program solves the (English) peg solitaire\n// board game.  See also:\n//   https://en.wikipedia.org/wiki/Peg_solitaire\n\npackage main\n\nimport \"fmt\"\n\nconst N = 11 + 1 // length of a board row (+1 for \\n)\n\n// The board must be surrounded by 2 illegal fields\n// in each direction so that move() doesn't need to\n// check the board boundaries. Periods represent\n// illegal fields, ● are pegs, and ○ are holes.\nvar board = []int(\n    `...........\n...........\n....●●●....\n....●●●....\n..●●●●●●●..\n..●●●○●●●..\n..●●●●●●●..\n....●●●....\n....●●●....\n...........\n...........\n`)\n\n\n// center is the position of the center hole if\n// there is a single one; otherwise it is -1.\nvar center int\n\nfunc init() {\n    n := 0\n    for pos, field := range board {\n        if field == '○' {\n            center = pos\n            n++\n        }\n    }\n    if n != 1 {\n        center = -1 // no single hole\n    }\n}\n\n\nvar moves int // number of times move is called\n\n// move tests if there is a peg at position pos that\n// can jump over another peg in direction dir. If the\n// move is valid, it is executed and move returns true.\n// Otherwise, move returns false.\nfunc move(pos, dir int) bool {\n    moves++\n    if board[pos] == '●' && board[pos+dir] == '●' && board[pos+2*dir] == '○' {\n        board[pos] = '○'\n        board[pos+dir] = '○'\n        board[pos+2*dir] = '●'\n        return true\n    }\n    return false\n}\n\n\n// unmove reverts a previously executed valid move.\nfunc unmove(pos, dir int) {\n    board[pos] = '●'\n    board[pos+dir] = '●'\n    board[pos+2*dir] = '○'\n}\n\n\n// solve tries to find a sequence of moves such that\n// there is only one peg left at the end; if center is\n// >= 0, that last peg must be in the center position.\n// If a solution is found, solve prints the board after\n// each move in a backward fashion (i.e., the last\n// board position is printed first, all the way back to\n// the starting board position).\nfunc solve() bool {\n    var last, n int\n    for pos, field := range board {\n        // try each board position\n        if field == '●' {\n            // found a peg\n            for _, dir := range [...]int{-1, -N, +1, +N} {\n                // try each direction\n                if move(pos, dir) {\n                    // a valid move was found and executed,\n                    // see if this new board has a solution\n                    if solve() {\n                        unmove(pos, dir)\n                        println(string(board))\n                        return true\n                    }\n                    unmove(pos, dir)\n                }\n            }\n            last = pos\n            n++\n        }\n    }\n    // tried each possible move\n    if n == 1 && (center < 0 || last == center) {\n        // there's only one peg left\n        println(string(board))\n        return true\n    }\n    // no solution found for this board\n    return false\n}\n\n\nfunc main() {\n    if !solve() {\n        fmt.Println(\"no solution found\")\n    }\n    fmt.Println(moves, \"moves tried\")\n}\n"
  },
  {
    "path": "Game solvers/reaction_time_test.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 16 August 2019\n# https://github.com/trizen\n\n# A simple program to cheat in the \"Reaction time test\".\n# https://www.humanbenchmark.com/tests/reactiontime\n\nuse 5.014;\nuse strict;\nuse warnings;\n\nuse GD;\nuse Time::HiRes qw(sleep);\n\nsay \"Starting...\";\nsleep 5;\nsystem(\"xdotool\", \"click\", \"1\");    # click to start\n\nmy $count = 0;\n\nwhile (1) {\n\n    my $gd = GD::Image->new(scalar `maim --geometry '20x20+1+300' --format=jpg /dev/stdout`);\n\n    my $pixel = $gd->getPixel(0, 0);    # test first pixel\n    my ($r, $g, $b) = $gd->rgb($pixel);\n\n    if ($g > 100) {                     # test for greenness\n        say \"Detected green...\";\n\n        system(\"xdotool\", \"click\", \"1\");    # green detected\n        last if ++$count == 5;\n\n        sleep(2);\n        system(\"xdotool\", \"click\", \"1\");    # click to continue\n        sleep 2;\n    }\n\n    sleep 0.0001;\n}\n"
  },
  {
    "path": "Game solvers/reflex_sheep_game.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 02 October 2015\n# Website: https://github.com/trizen\n\n# A simple program which plays the Reflex Sheep game by itself.\n# See: https://youtu.be/FrYFE4m8jc0\n\nuse strict;\nuse warnings;\n\nuse GD;\nuse Time::HiRes qw(sleep);\n\nmy $count = 0;\n\nROOT: while (1) {\n\n    my $gd = GD::Image->new(scalar `maim -x 640 -y 150 -w 1 -h 850 --format=jpg /dev/stdout`);\n\n    #my $gd = GD::Image->new(scalar `maim -x 555 -y 100 -w 10 -h 650 --format=jpg /dev/stdout`);      # faster, but buggy\n\n    my ($width, $height) = $gd->getBounds;\n\n  OUTER: foreach my $y (0 .. $height - 1) {\n        my $pixel = $gd->getPixel(0, $y);\n        my ($r, $g, $b) = $gd->rgb($pixel);\n        my $avg = ($r + $g + $b) / 3;\n        if ($avg < 50) {\n            sleep(0.085);    # let the ship run a little bit more\n            system(\"xdotool\", \"click\", \"1\");\n            sleep(1);        # sleep a little bit after the click\n            ++$count == 5 ? last ROOT: last OUTER;\n        }\n    }\n}\n"
  },
  {
    "path": "Game solvers/sudoku_dice_game_solver.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 30 June 2013\n# https://github.com/trizen\n\n# Sudoku dice game solver\n\nuse strict;\nuse warnings;\n\nuse List::Util qw(first shuffle);\n\nsub valid_move {\n    my ($row, $col, $table) = @_;\n\n    if (($row < 0 or not exists $table->[$row]) || ($col < 0 or not exists $table->[$row][$col])) {\n        return;\n    }\n\n    return 1;\n}\n\n{\n    my @moves = (\n                 {dir => 'left',  pos => [+0, -1]},\n                 {dir => 'right', pos => [+0, +1]},\n                 {dir => 'up',    pos => [-1, +0]},\n                 {dir => 'down',  pos => [+1, +0]},\n                );\n\n    sub get_moves {\n        my ($table, $row, $col, $number) = @_;\n\n        my @next_pos;\n        foreach my $move (@moves) {\n            if (valid_move($row + $move->{pos}[0], $col + $move->{pos}[1], $table)) {\n                if (    $table->[$row + $move->{pos}[0]][$col + $move->{pos}[1]] != 0\n                    and $table->[$row + $move->{pos}[0]][$col + $move->{pos}[1]] == $number + 1) {\n                    push @next_pos, $move;\n                }\n            }\n        }\n\n        return \\@next_pos;\n    }\n}\n\nmy @steps;\n\nsub init_universe {    # recursion at its best\n    my ($table, $pos) = @_;\n    my ($row,   $col) = @{$pos};\n\n    my $number = $table->[$row][$col];\n    $table->[$row][$col] = 0;\n\n    if ($number == 0) {\n        pop @steps;\n        return $table;\n    }\n\n    $number = 0 if $number == 3;\n    my $moves = get_moves($table, $row, $col, $number);\n\n    if (@{$moves}) {\n\n        foreach my $move (@{$moves}) {\n            push @steps, $move;\n\n            my $universe = init_universe([map { [@{$_}] } @{$table}], [$row + $move->{pos}[0], $col + $move->{pos}[1]]);\n\n            if (\n                not first {\n                    first { $_ != 0 } @{$_};\n                }\n                @{$universe}\n              ) {\n                die \"solved\\n\";\n            }\n        }\n\n        return init_universe($table, [$row, $col]);\n    }\n    else {\n        pop @steps;\n        return $table;\n    }\n}\n\n#\n## MAIN\n#\n\n{\n    my @rows = qw(\n      321321313\n      123312222\n      321213131\n      312231123\n      213112321\n      231323123\n      132231231\n      123113322\n      321322113\n      );\n\n    my @table;\n    foreach my $row (@rows) {\n        push @table, [split //, $row];\n    }\n\n    my @positions;\n    foreach my $i (0 .. $#table) {\n        foreach my $j (0 .. $#{$table[$i]}) {\n            if ($table[$i][$j] == 1) {\n                push @positions, [$i, $j];\n            }\n        }\n    }\n\n    foreach my $pos (shuffle @positions) {    # tested solution from position[6]\n\n        eval {\n            init_universe([map { [@{$_}] } @table], $pos);\n        };\n\n        if ($@ eq \"solved\\n\") {\n\n            printf \"** Locate row %d, column %d, click on it and follow the steps:\\n\", ($pos->[0] + 1, $pos->[1] + 1);\n\n            my $i         = 1;\n            my $count     = 1;\n            my $prev_step = (shift @steps)->{dir};\n\n            foreach my $step (@steps) {\n                if ($step->{dir} eq $prev_step) {\n                    ++$count;\n                }\n                else {\n                    printf \"%2d. Go %-8s%s\", $i++, $prev_step, ($count == 1 ? \"\\n\" : \"($count times)\\n\");\n                    $count     = 1;\n                    $prev_step = $step->{dir};\n                }\n            }\n\n            print \"\\n\";\n            @steps = ();\n        }\n    }\n}\n"
  },
  {
    "path": "Game solvers/sudoku_generator.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 30 January 2017\n# Edit: 20 December 2021\n# https://github.com/trizen\n\n# Recursive brute-force Sudoku generator and solver.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Sudoku\n\nuse 5.020;\nuse strict;\n\nuse List::Util qw(shuffle);\nuse experimental qw(signatures);\n\nsub check ($i, $j) {\n\n    use integer;\n\n    my ($id, $im) = ($i / 9, $i % 9);\n    my ($jd, $jm) = ($j / 9, $j % 9);\n\n    $jd == $id && return 1;\n    $jm == $im && return 1;\n\n        $id / 3 == $jd / 3\n    and $jm / 3 == $im / 3;\n}\n\nmy @lookup;\nforeach my $i (0 .. 80) {\n    foreach my $j (0 .. 80) {\n        $lookup[$i][$j] = check($i, $j);\n    }\n}\n\nsub solve_sudoku ($callback, $grid) {\n\n    sub {\n        foreach my $i (0 .. 80) {\n            if (!$grid->[$i]) {\n\n                my %t;\n                undef @t{@{$grid}[grep { $lookup[$i][$_] } 0 .. 80]};\n\n                foreach my $k (shuffle(1 .. 9)) {\n                    if (!exists $t{$k}) {\n                        $grid->[$i] = $k;\n                        __SUB__->();\n                        $grid->[$i] = 0;\n                    }\n                }\n\n                return;\n            }\n        }\n\n        $callback->(@$grid);\n      }\n      ->();\n}\n\nsub generate_sudoku ($known, $solution_count = 1) {\n\n    my @grid = (0) x 81;\n\n    eval {\n        solve_sudoku(\n            sub {\n                my (@solution) = @_;\n\n                my %table;\n                @table{(shuffle(0 .. $#solution))[0 .. $known - 1]} = ();\n\n                my @candidate = map { exists($table{$_}) ? $solution[$_] : 0 } 0 .. $#solution;\n\n                my $res = eval {\n                    my $count = 0;\n                    solve_sudoku(sub { die \"error\" if (++$count > $solution_count) }, [@candidate]);\n                    $count;\n                };\n\n                if (defined($res) and $res == $solution_count) {\n                    @grid = @candidate;\n                    die \"found\";\n                }\n            },\n            \\@grid\n                    );\n    };\n\n    return @grid;\n}\n\nsub display_grid_as_ascii_table {\n    my (@grid) = @_;\n\n    my $t = Text::ASCIITable->new();\n    $t->setCols(map { '1 2 3' } 1 .. 3);\n    $t->setOptions({hide_HeadLine => 1, hide_HeadRow => 1});\n\n    my @collect;\n\n    foreach my $i (0 .. $#grid) {\n\n        push @collect, $grid[$i] ? $grid[$i] : '0';\n\n        if (($i + 1) % 9 == 0) {\n            my @row = splice(@collect);\n\n            my @chunks;\n            while (@row) {\n                push @chunks, join ' ', splice(@row, 0, 3);\n            }\n\n            $t->addRow(@chunks);\n        }\n\n        if (($i + 1) % 27 == 0) {\n            $t->addRowLine();\n        }\n    }\n\n    print $t;\n}\n\nsub display_grid {\n    my (@grid) = @_;\n\n    my $has_ascii_table = eval { require Text::ASCIITable; 1 };\n\n    if ($has_ascii_table) {\n        return display_grid_as_ascii_table(@grid);\n    }\n\n    foreach my $i (0 .. $#grid) {\n        print \"$grid[$i] \";\n        print \" \"  if ($i + 1) % 3 == 0;\n        print \"\\n\" if ($i + 1) % 9 == 0;\n        print \"\\n\" if ($i + 1) % 27 == 0;\n    }\n}\n\nmy $known          = 35;    # number of known entries\nmy $solution_count = 1;     # number of solutions the puzzle must have\n\nmy @sudoku = generate_sudoku($known, $solution_count);\n\nsay \"\\n:: Random Sudoku with $known known entries:\\n\";\n\ndisplay_grid(@sudoku);\n\nsay \"\\n:: Solution(s):\\n\";\n\nsolve_sudoku(\n    sub {\n        my (@solution) = @_;\n        display_grid(@solution);\n    },\n    \\@sudoku\n            );\n\n__END__\n\n:: Random Sudoku with 35 known entries:\n\n.-----------------------.\n| 8 9 0 | 6 4 5 | 2 0 3 |\n| 7 4 0 | 8 0 0 | 9 0 0 |\n| 0 0 5 | 0 3 0 | 8 1 4 |\n+-------+-------+-------+\n| 3 0 0 | 0 0 9 | 0 0 1 |\n| 0 1 2 | 4 7 0 | 5 0 8 |\n| 0 8 0 | 0 0 0 | 4 3 0 |\n+-------+-------+-------+\n| 1 0 0 | 0 6 0 | 3 0 0 |\n| 0 0 0 | 0 0 0 | 0 0 5 |\n| 0 0 0 | 0 5 4 | 7 0 0 |\n'-------+-------+-------'\n\n:: Solution(s):\n\n.-----------------------.\n| 8 9 1 | 6 4 5 | 2 7 3 |\n| 7 4 3 | 8 2 1 | 9 5 6 |\n| 2 6 5 | 9 3 7 | 8 1 4 |\n+-------+-------+-------+\n| 3 7 4 | 5 8 9 | 6 2 1 |\n| 6 1 2 | 4 7 3 | 5 9 8 |\n| 5 8 9 | 2 1 6 | 4 3 7 |\n+-------+-------+-------+\n| 1 5 8 | 7 6 2 | 3 4 9 |\n| 4 2 7 | 3 9 8 | 1 6 5 |\n| 9 3 6 | 1 5 4 | 7 8 2 |\n'-------+-------+-------'\n"
  },
  {
    "path": "Game solvers/sudoku_solver.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 30 January 2017\n# https://github.com/trizen\n\n# Recursive brute-force Sudoku solver.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Sudoku\n\nuse 5.016;\nuse strict;\n\nsub check {\n    my ($i, $j) = @_;\n\n    use integer;\n\n    my ($id, $im) = ($i / 9, $i % 9);\n    my ($jd, $jm) = ($j / 9, $j % 9);\n\n    $jd == $id && return 1;\n    $jm == $im && return 1;\n\n        $id / 3 == $jd / 3\n    and $jm / 3 == $im / 3;\n}\n\nmy @lookup;\nforeach my $i (0 .. 80) {\n    foreach my $j (0 .. 80) {\n        $lookup[$i][$j] = check($i, $j);\n    }\n}\n\nsub solve_sudoku {\n    my ($callback, @grid) = @_;\n\n    sub {\n        foreach my $i (0 .. 80) {\n            if (!$grid[$i]) {\n\n                my %t;\n                undef @t{@grid[grep { $lookup[$i][$_] } 0 .. 80]};\n\n                foreach my $k (1 .. 9) {\n                    if (!exists $t{$k}) {\n                        $grid[$i] = $k;\n                        __SUB__->();\n                        $grid[$i] = 0;\n                    }\n                }\n\n                return;\n            }\n        }\n\n        $callback->(@grid);\n    }->();\n}\n\n#<<<\nmy @grid = qw(\n    5 3 0  0 7 0  0 0 0\n    6 0 0  1 9 5  0 0 0\n    0 9 8  0 0 0  0 6 0\n\n    8 0 0  0 6 0  0 0 3\n    4 0 0  8 0 3  0 0 1\n    7 0 0  0 2 0  0 0 6\n\n    0 6 0  0 0 0  2 8 0\n    0 0 0  4 1 9  0 0 5\n    0 0 0  0 8 0  0 7 9\n);\n\n@grid = qw(\n    0 0 0  8 0 1  0 0 0\n    0 0 0  0 0 0  0 4 3\n    5 0 0  0 0 0  0 0 0\n\n    0 0 0  0 7 0  8 0 0\n    0 0 0  0 0 0  1 0 0\n    0 2 0  0 3 0  0 0 0\n\n    6 0 0  0 0 0  0 7 5\n    0 0 3  4 0 0  0 0 0\n    0 0 0  2 0 0  6 0 0\n) if 0;\n\n@grid = qw(\n    8 0 0  0 0 0  0 0 0\n    0 0 3  6 0 0  0 0 0\n    0 7 0  0 9 0  2 0 0\n\n    0 5 0  0 0 7  0 0 0\n    0 0 0  0 4 5  7 0 0\n    0 0 0  1 0 0  0 3 0\n\n    0 0 1  0 0 0  0 6 8\n    0 0 8  5 0 0  0 1 0\n    0 9 0  0 0 0  4 0 0\n) if 0;\n#>>>\n\nsolve_sudoku(\n    sub {\n        say \"Solution:\";\n        my (@solution) = @_;\n        foreach my $i (0 .. $#solution) {\n            print \"$solution[$i] \";\n            print \" \"  if ($i + 1) % 3 == 0;\n            print \"\\n\" if ($i + 1) % 9 == 0;\n            print \"\\n\" if ($i + 1) % 27 == 0;\n        }\n    }, @grid\n);\n"
  },
  {
    "path": "Game solvers/sudoku_solver_backtracking.pl",
    "content": "#!/usr/bin/perl\n\n# Solve Sudoku puzzle (recursive solution).\n\nuse 5.036;\n\nsub is_valid ($board, $row, $col, $num) {\n\n    # Check if the number is not present in the current row and column\n    foreach my $i (0 .. 8) {\n        if (($board->[$row][$i] == $num) || ($board->[$i][$col] == $num)) {\n            return 0;\n        }\n    }\n\n    # Check if the number is not present in the current 3x3 subgrid\n    my ($start_row, $start_col) = (3 * int($row / 3), 3 * int($col / 3));\n\n    foreach my $i (0 .. 2) {\n        foreach my $j (0 .. 2) {\n            if ($board->[$start_row + $i][$start_col + $j] == $num) {\n                return 0;\n            }\n        }\n    }\n\n    return 1;\n}\n\nsub find_empty_location ($board) {\n\n    # Find an empty position (cell with 0)\n    foreach my $i (0 .. 8) {\n        foreach my $j (0 .. 8) {\n            if ($board->[$i][$j] == 0) {\n                return ($i, $j);\n            }\n        }\n    }\n\n    return (undef, undef);    # If the board is filled\n}\n\nsub solve_sudoku ($board) {\n    my ($row, $col) = find_empty_location($board);\n\n    if (!defined($row) && !defined($col)) {\n        return 1;    # Puzzle is solved\n    }\n\n    foreach my $num (1 .. 9) {\n        if (is_valid($board, $row, $col, $num)) {\n\n            # Try placing the number\n            $board->[$row][$col] = $num;\n\n            # Recursively try to solve the rest of the puzzle\n            if (__SUB__->($board)) {\n                return 1;\n            }\n\n            # If placing the current number doesn't lead to a solution, backtrack\n            $board->[$row][$col] = 0;\n        }\n    }\n\n    return 0;    # No solution found\n}\n\n#<<<\n# Example usage:\n# Define the Sudoku puzzle as a 9x9 list with 0 representing empty cells\nmy $sudoku_board = [\n        [2, 0, 0, 0, 7, 0, 0, 0, 3],\n        [1, 0, 0, 0, 0, 0, 0, 8, 0],\n        [0, 0, 4, 2, 0, 9, 0, 0, 5],\n        [9, 4, 0, 0, 0, 0, 6, 0, 8],\n        [0, 0, 0, 8, 0, 0, 0, 9, 0],\n        [0, 0, 0, 0, 0, 0, 0, 7, 0],\n        [7, 2, 1, 9, 0, 8, 0, 6, 0],\n        [0, 3, 0, 0, 2, 7, 1, 0, 0],\n        [4, 0, 0, 0, 0, 3, 0, 0, 0]\n];\n\n$sudoku_board = [\n    [0, 0, 0, 8, 0, 1, 0, 0, 0],\n    [0, 0, 0, 0, 0, 0, 0, 4, 3],\n    [5, 0, 0, 0, 0, 0, 0, 0, 0],\n    [0, 0, 0, 0, 7, 0, 8, 0, 0],\n    [0, 0, 0, 0, 0, 0, 1, 0, 0],\n    [0, 2, 0, 0, 3, 0, 0, 0, 0],\n    [6, 0, 0, 0, 0, 0, 0, 7, 5],\n    [0, 0, 3, 4, 0, 0, 0, 0, 0],\n    [0, 0, 0, 2, 0, 0, 6, 0, 0]\n] if 0;\n\n$sudoku_board = [\n    [8, 0, 0, 0, 0, 0, 0, 0, 0],\n    [0, 0, 3, 6, 0, 0, 0, 0, 0],\n    [0, 7, 0, 0, 9, 0, 2, 0, 0],\n    [0, 5, 0, 0, 0, 7, 0, 0, 0],\n    [0, 0, 0, 0, 4, 5, 7, 0, 0],\n    [0, 0, 0, 1, 0, 0, 0, 3, 0],\n    [0, 0, 1, 0, 0, 0, 0, 6, 8],\n    [0, 0, 8, 5, 0, 0, 0, 1, 0],\n    [0, 9, 0, 0, 0, 0, 4, 0, 0]\n] if 0;\n#>>>\n\nsub display_grid ($grid) {\n    foreach my $i (0 .. $#$grid) {\n        print \"$grid->[$i] \";\n        print \" \"  if ($i + 1) % 3 == 0;\n        print \"\\n\" if ($i + 1) % 9 == 0;\n        print \"\\n\" if ($i + 1) % 27 == 0;\n    }\n}\n\nif (solve_sudoku($sudoku_board)) {\n    display_grid([map { @$_ } @$sudoku_board]);\n}\nelse {\n    say \"No solution exists.\";\n}\n"
  },
  {
    "path": "Game solvers/sudoku_solver_iterative.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 12 February 2024\n# https://github.com/trizen\n\n# Fast algorithm to solve the Sudoku puzzle (iterative solution).\n\nuse 5.036;\n\nsub is_valid ($board, $row, $col, $num) {\n\n    # Check if the number is not present in the current row and column\n    foreach my $i (0 .. 8) {\n        if (($board->[$row][$i] == $num) || ($board->[$i][$col] == $num)) {\n            return 0;\n        }\n    }\n\n    # Check if the number is not present in the current 3x3 subgrid\n    my ($start_row, $start_col) = (3 * int($row / 3), 3 * int($col / 3));\n\n    foreach my $i (0 .. 2) {\n        foreach my $j (0 .. 2) {\n            if ($board->[$start_row + $i][$start_col + $j] == $num) {\n                return 0;\n            }\n        }\n    }\n\n    return 1;\n}\n\nsub find_empty_locations ($board) {\n\n    my @locations;\n\n    # Find all empty positions (cells with 0)\n    foreach my $i (0 .. 8) {\n        foreach my $j (0 .. 8) {\n            if ($board->[$i][$j] == 0) {\n                push @locations, [$i, $j];\n            }\n        }\n    }\n\n    return @locations;\n}\n\nsub find_empty_location ($board) {\n\n    # Find an empty position (cell with 0)\n    foreach my $i (0 .. 8) {\n        foreach my $j (0 .. 8) {\n            if ($board->[$i][$j] == 0) {\n                return ($i, $j);\n            }\n        }\n    }\n\n    return (undef, undef);    # If the board is filled\n}\n\nsub solve_sudoku_fallback ($board) {    # fallback method\n\n    my ($row, $col) = find_empty_location($board);\n\n    if (!defined($row) && !defined($col)) {\n        return 1;    # Puzzle is solved\n    }\n\n    foreach my $num (1 .. 9) {\n        if (is_valid($board, $row, $col, $num)) {\n\n            # Try placing the number\n            $board->[$row][$col] = $num;\n\n            # Recursively try to solve the rest of the puzzle\n            if (__SUB__->($board)) {\n                return 1;\n            }\n\n            # If placing the current number doesn't lead to a solution, backtrack\n            $board->[$row][$col] = 0;\n        }\n    }\n\n    return 0;    # No solution found\n}\n\nsub solve_sudoku ($board) {\n\n    while (1) {\n        (my @empty_locations = find_empty_locations($board)) || last;\n\n        my $found = 0;\n\n        # Solve easy cases\n        foreach my $ij (@empty_locations) {\n            my ($i,     $j)     = @$ij;\n            my ($count, $value) = (0, 0);\n            foreach my $n (1 .. 9) {\n                is_valid($board, $i, $j, $n) || next;\n                last if (++$count > 1);\n                $value = $n;\n            }\n            if ($count == 1) {\n                $board->[$i][$j] = $value;\n                $found ||= 1;\n            }\n        }\n\n        next if $found;\n\n        # Solve more complex cases\n        my @stats;\n        foreach my $ij (@empty_locations) {\n            my ($i, $j) = @$ij;\n            $stats[$i][$j] = [grep { is_valid($board, $i, $j, $_) } 1 .. 9];\n        }\n\n        my (@rows, @cols, @subgrid);\n        foreach my $ij (@empty_locations) {\n            my ($i, $j) = @$ij;\n            foreach my $v (@{$stats[$i][$j]}) {\n                ++$cols[$j][$v];\n                ++$rows[$i][$v];\n                ++$subgrid[3 * int($i / 3)][3 * int($j / 3)][$v];\n            }\n        }\n\n        foreach my $ij (@empty_locations) {\n            my ($i, $j) = @$ij;\n            foreach my $v (@{$stats[$i][$j]}) {\n                if (   $cols[$j][$v] == 1\n                    or $rows[$i][$v] == 1\n                    or $subgrid[3 * int($i / 3)][3 * int($j / 3)][$v] == 1) {\n                    $board->[$i][$j] = $v;\n                    $found ||= 1;\n                }\n            }\n        }\n\n        next if $found;\n\n        # Give up and try brute-force\n        solve_sudoku_fallback($board);\n        return $board;\n    }\n\n    return $board;\n}\n\n#<<<\n# Example usage:\n# Define the Sudoku puzzle as a 9x9 list with 0 representing empty cells\nmy $sudoku_board = [\n        [2, 0, 0, 0, 7, 0, 0, 0, 3],\n        [1, 0, 0, 0, 0, 0, 0, 8, 0],\n        [0, 0, 4, 2, 0, 9, 0, 0, 5],\n        [9, 4, 0, 0, 0, 0, 6, 0, 8],\n        [0, 0, 0, 8, 0, 0, 0, 9, 0],\n        [0, 0, 0, 0, 0, 0, 0, 7, 0],\n        [7, 2, 1, 9, 0, 8, 0, 6, 0],\n        [0, 3, 0, 0, 2, 7, 1, 0, 0],\n        [4, 0, 0, 0, 0, 3, 0, 0, 0]\n];\n\n$sudoku_board = [\n    [0, 0, 0, 8, 0, 1, 0, 0, 0],\n    [0, 0, 0, 0, 0, 0, 0, 4, 3],\n    [5, 0, 0, 0, 0, 0, 0, 0, 0],\n    [0, 0, 0, 0, 7, 0, 8, 0, 0],\n    [0, 0, 0, 0, 0, 0, 1, 0, 0],\n    [0, 2, 0, 0, 3, 0, 0, 0, 0],\n    [6, 0, 0, 0, 0, 0, 0, 7, 5],\n    [0, 0, 3, 4, 0, 0, 0, 0, 0],\n    [0, 0, 0, 2, 0, 0, 6, 0, 0]\n] if 1;\n\n$sudoku_board = [\n    [8, 0, 0, 0, 0, 0, 0, 0, 0],\n    [0, 0, 3, 6, 0, 0, 0, 0, 0],\n    [0, 7, 0, 0, 9, 0, 2, 0, 0],\n    [0, 5, 0, 0, 0, 7, 0, 0, 0],\n    [0, 0, 0, 0, 4, 5, 7, 0, 0],\n    [0, 0, 0, 1, 0, 0, 0, 3, 0],\n    [0, 0, 1, 0, 0, 0, 0, 6, 8],\n    [0, 0, 8, 5, 0, 0, 0, 1, 0],\n    [0, 9, 0, 0, 0, 0, 4, 0, 0]\n] if 0;\n#>>>\n\nsub display_grid ($grid) {\n    foreach my $i (0 .. $#$grid) {\n        print \"$grid->[$i] \";\n        print \" \"  if ($i + 1) % 3 == 0;\n        print \"\\n\" if ($i + 1) % 9 == 0;\n        print \"\\n\" if ($i + 1) % 27 == 0;\n    }\n}\n\nmy $solution = solve_sudoku($sudoku_board);\n\nif ($solution) {\n    display_grid([map { @$_ } @$solution]);\n}\nelse {\n    warn \"No unique solution exists!\\n\";\n}\n"
  },
  {
    "path": "Game solvers/sudoku_solver_stack.pl",
    "content": "#!/usr/bin/perl\n\n# Solve Sudoku puzzle (iterative solution // stack-based).\n\nuse 5.036;\n\nsub is_valid ($board, $row, $col, $num) {\n\n    # Check if the number is not present in the current row and column\n    foreach my $i (0 .. 8) {\n        if (($board->[$row][$i] == $num) || ($board->[$i][$col] == $num)) {\n            return 0;\n        }\n    }\n\n    # Check if the number is not present in the current 3x3 subgrid\n    my ($start_row, $start_col) = (3 * int($row / 3), 3 * int($col / 3));\n\n    foreach my $i (0 .. 2) {\n        foreach my $j (0 .. 2) {\n            if ($board->[$start_row + $i][$start_col + $j] == $num) {\n                return 0;\n            }\n        }\n    }\n\n    return 1;\n}\n\nsub find_empty_location ($board) {\n\n    # Find an empty position (cell with 0)\n    foreach my $i (0 .. 8) {\n        foreach my $j (0 .. 8) {\n            if ($board->[$i][$j] == 0) {\n                return ($i, $j);\n            }\n        }\n    }\n\n    return (undef, undef);    # If the board is filled\n}\n\nsub solve_sudoku ($board) {\n\n    my @stack = ($board);\n\n    while (@stack) {\n\n        my $current_board = pop @stack;\n        my ($row, $col) = find_empty_location($current_board);\n\n        if (!defined($row) && !defined($col)) {\n            return $current_board;\n        }\n\n        foreach my $num (1 .. 9) {\n            if (is_valid($current_board, $row, $col, $num)) {\n                my @new_board = map { [@$_] } @$current_board;\n                $new_board[$row][$col] = $num;\n                push @stack, \\@new_board;\n            }\n        }\n    }\n\n    return undef;\n}\n\n#<<<\n# Example usage:\n# Define the Sudoku puzzle as a 9x9 list with 0 representing empty cells\nmy $sudoku_board = [\n        [2, 0, 0, 0, 7, 0, 0, 0, 3],\n        [1, 0, 0, 0, 0, 0, 0, 8, 0],\n        [0, 0, 4, 2, 0, 9, 0, 0, 5],\n        [9, 4, 0, 0, 0, 0, 6, 0, 8],\n        [0, 0, 0, 8, 0, 0, 0, 9, 0],\n        [0, 0, 0, 0, 0, 0, 0, 7, 0],\n        [7, 2, 1, 9, 0, 8, 0, 6, 0],\n        [0, 3, 0, 0, 2, 7, 1, 0, 0],\n        [4, 0, 0, 0, 0, 3, 0, 0, 0]\n];\n\n$sudoku_board = [\n    [0, 0, 0, 8, 0, 1, 0, 0, 0],\n    [0, 0, 0, 0, 0, 0, 0, 4, 3],\n    [5, 0, 0, 0, 0, 0, 0, 0, 0],\n    [0, 0, 0, 0, 7, 0, 8, 0, 0],\n    [0, 0, 0, 0, 0, 0, 1, 0, 0],\n    [0, 2, 0, 0, 3, 0, 0, 0, 0],\n    [6, 0, 0, 0, 0, 0, 0, 7, 5],\n    [0, 0, 3, 4, 0, 0, 0, 0, 0],\n    [0, 0, 0, 2, 0, 0, 6, 0, 0]\n] if 0;\n\n$sudoku_board = [\n    [8, 0, 0, 0, 0, 0, 0, 0, 0],\n    [0, 0, 3, 6, 0, 0, 0, 0, 0],\n    [0, 7, 0, 0, 9, 0, 2, 0, 0],\n    [0, 5, 0, 0, 0, 7, 0, 0, 0],\n    [0, 0, 0, 0, 4, 5, 7, 0, 0],\n    [0, 0, 0, 1, 0, 0, 0, 3, 0],\n    [0, 0, 1, 0, 0, 0, 0, 6, 8],\n    [0, 0, 8, 5, 0, 0, 0, 1, 0],\n    [0, 9, 0, 0, 0, 0, 4, 0, 0]\n] if 0;\n#>>>\n\nsub display_grid ($grid) {\n    foreach my $i (0 .. $#$grid) {\n        print \"$grid->[$i] \";\n        print \" \"  if ($i + 1) % 3 == 0;\n        print \"\\n\" if ($i + 1) % 9 == 0;\n        print \"\\n\" if ($i + 1) % 27 == 0;\n    }\n}\n\nmy $solution = solve_sudoku($sudoku_board);\n\nif ($solution) {\n    display_grid([map { @$_ } @$solution]);\n}\nelse {\n    say \"No solution exists.\";\n}\n"
  },
  {
    "path": "Game solvers/visual_memory_test.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 22 September 2019\n# https://github.com/trizen\n\n# A simple program that can solve the \"Visual Memory Test\" from Human Benchmark.\n# https://www.humanbenchmark.com/tests/memory\n\n# The program uses the `maim` and `swarp` tools to control the mouse.\n\n# See also:\n#   https://github.com/naelstrof/maim\n#   https://tools.suckless.org/x/swarp/\n\n# The current highest level reached by this program is 38.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse GD qw();\nuse Time::HiRes qw(sleep);\nuse experimental qw(signatures);\n\nGD::Image->trueColor(1);\n\nsub avg {\n    ($_[0] + $_[1] + $_[2]) / 3;\n}\n\nsub img2ascii ($image) {\n\n    my $size = 1920;\n\n    my $img = GD::Image->new($image) // return;\n    my ($width, $height) = $img->getBounds;\n\n    if ($size != 0) {\n        my $scale_width  = $size;\n        my $scale_height = int($height / ($width / ($size / 2)));\n\n        my $resized = GD::Image->new($scale_width, $scale_height);\n        $resized->copyResampled($img, 0, 0, 0, 0, $scale_width, $scale_height, $width, $height);\n\n        ($width, $height) = ($scale_width, $scale_height);\n        $img = $resized;\n    }\n\n    my $avg = 0;\n    my @averages;\n\n    foreach my $y (0 .. $height - 1) {\n        foreach my $x (0 .. $width - 1) {\n            my $index = $img->getPixel($x, $y);\n            push @averages, avg($img->rgb($index));\n            $avg += $averages[-1] / $width / $height;\n        }\n    }\n\n    unpack(\"(A$width)*\", join('', map { $_ < $avg ? 1 : 0 } @averages));\n}\n\nsub solve (@lines) {\n\n    my $width_offset  = 760;\n    my $height_offset = 130;\n\n    @lines = @lines[$height_offset - 1 .. 320];\n\n    while (@lines and $lines[0] =~ /^1+\\z/) {\n        shift @lines;\n        ++$height_offset;\n    }\n\n    @lines = map { substr($_, $width_offset, 385) } @lines;\n\n    my $square_height = 0;\n\n    foreach my $i (0 .. $#lines) {\n        if ($lines[$i] =~ /0/) {\n            ++$square_height;\n        }\n\n        if ($square_height > 0 and $lines[$i] !~ /0/) {\n            last;\n        }\n    }\n\n    if ($square_height == 0) {\n        warn \"Can't determine square height...\";\n        return;\n    }\n\n    my $left_index   = 0;\n    my $square_width = 0;\n\n  OUTER: foreach my $i (0 .. 100) {\n        foreach my $line (@lines) {\n            if (substr($line, $i, 1) eq '0') {\n                $left_index = $i;\n                $line =~ /^1*(0+)/;\n                $square_width = length($1);\n                last OUTER;\n            }\n        }\n    }\n\n    if ($square_width == 0) {\n        warn \"Can't determine square width...\";\n        return;\n    }\n\n    say \"Left index: $left_index\";\n    say \"Square width: $square_width\";\n    say \"Square height: $square_height\";\n\n    my @grid;\n    my $size = int(length($lines[0]) / $square_width);\n\n    if ($size < 3) {\n        warn \"Can't determine the size of the grid...\";\n        return;\n    }\n\n    if ($size > 20) {\n        warn \"Incorrect size of the grid...\";\n        return;\n    }\n\n    my $width_gap  = 10;\n    my $height_gap = 4;\n\n    if ($size >= 6) {\n        $width_gap  = 9;\n        $height_gap = 3;\n    }\n\n    if ($size >= 8) {\n        $width_gap = 8;\n    }\n\n    if ($size >= 10) {\n        $width_gap = 5;\n    }\n\n    if ($size >= 11) {\n        $width_gap  = 4;\n        $height_gap = 2;\n    }\n\n    say \"Size: $size x $size\";\n\n    foreach my $i (0 .. $size - 1) {\n        foreach my $j (0 .. $size - 1) {\n            my @square;\n            foreach my $line (\n                 @lines[$square_height * $i + $height_gap * $i .. $square_height * $i + $height_gap * $i + $square_height - 1])\n            {\n                push @square, substr($line, $square_width * $j + $width_gap * $j, $square_width);\n            }\n            $grid[$i][$j] = \\@square;\n        }\n    }\n\n    my @matrix;\n\n    foreach my $i (0 .. $#grid) {\n        my $row = $grid[$i];\n        foreach my $j (0 .. $#$row) {\n            my $square = $row->[$j];\n\n            my %freq = ('0' => 0, '1' => 0);\n            ++$freq{$_} for split(//, join('', @$square));\n            $matrix[$i][$j] = ($freq{'0'} > $freq{'1'}) ? 1 : 0;\n        }\n    }\n\n    say \"@$_\" for @matrix;\n\n    foreach my $i (0 .. $#matrix) {\n        foreach my $j (0 .. $#{$matrix[0]}) {\n            if ($matrix[$i][$j]) {\n\n                my $x = int($width_offset + $square_width * $j + $square_width / 2 + $width_gap * $j);\n                my $y = int(2 * $height_offset + $square_height * 2 * $i + $square_height / 2 + 2 * $height_gap * $i);\n\n                #say \"Changing pointer to ($x, $y)\";\n                system(\"swarp\", $x, $y);\n\n                #say \"Clicking square...\";\n                system(\"xdotool\", \"click\", \"1\");\n            }\n        }\n    }\n}\n\nif (@ARGV) {\n    solve(img2ascii($ARGV[0]));\n    exit;\n}\n\nwhile (1) {\n    print \"Press <ENTER> to take screenshot: \";\n    my $prompt = <STDIN>;\n    my $sshot  = `maim --geometry '1920x700+0+0' --format=jpg /dev/stdout`;\n    my @lines  = img2ascii($sshot);\n    sleep 1;\n    solve(@lines);\n    system(\"swarp\",   1700,    800);\n    system(\"xdotool\", \"click\", \"1\");\n}\n"
  },
  {
    "path": "Games/arrow-key_drawer.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 25 June 2015\n# Edit: 26 February 2023\n# Website: https://github.com/trizen\n\n# Draw right-angle abstract-art using the arrow-keys.\n\nuse utf8;\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Time::HiRes     qw(sleep);\nuse Term::ANSIColor qw(colored);\nuse Term::ReadKey   qw(ReadMode ReadLine);\n\nbinmode(STDOUT, ':utf8');\n\nuse constant {\n              VOID => 0,\n              HEAD => 1,\n              BODY => 2,\n             };\n\nuse constant {\n              LEFT  => [+0, -1],\n              RIGHT => [+0, +1],\n              UP    => [-1, +0],\n              DOWN  => [+1, +0],\n             };\n\nuse constant {BG_COLOR  => 'on_black'};\nuse constant {PEN_COLOR => ('bold green' . ' ' . BG_COLOR)};\n\nuse constant {\n    U_HEAD => colored('▲', PEN_COLOR),\n    D_HEAD => colored('▼', PEN_COLOR),\n    L_HEAD => colored('◀', PEN_COLOR),\n    R_HEAD => colored('▶', PEN_COLOR),\n\n    U_BODY => colored('■', PEN_COLOR),\n    D_BODY => colored('■', PEN_COLOR),\n    L_BODY => colored('■', PEN_COLOR),\n    R_BODY => colored('■', PEN_COLOR),\n\n    A_VOID => colored(' ', BG_COLOR),\n};\n\nmy $sleep = 0.07;    # sleep duration between displays\n\nlocal $| = 1;\n\nmy $w = eval { `tput cols` }  || 80;\nmy $h = eval { `tput lines` } || 24;\nmy $r = \"\\033[H\";\n\nmy @grid = map {\n    [map { [VOID] } 1 .. $w]\n} 1 .. $h;\n\nmy $dir      = LEFT;\nmy @head_pos = ($h / 2, $w / 2);\nmy @tail_pos = ($head_pos[0], $head_pos[1] + 1);\n\n$grid[$head_pos[0]][$head_pos[1]] = [HEAD, $dir];    # head\n\nsub display {\n    print $r, join(\n        \"\\n\",\n        map {\n            join(\n                \"\",\n                map {\n                    my $t = $_->[0];\n                    my $p = $_->[1] // '';\n\n                    my $i =\n                        $p eq UP   ? 0\n                      : $p eq DOWN ? 1\n                      : $p eq LEFT ? 2\n                      :              3;\n\n                        $t == HEAD ? (U_HEAD, D_HEAD, L_HEAD, R_HEAD)[$i]\n                      : $t == BODY ? (U_BODY, D_BODY, L_BODY, R_BODY)[$i]\n                      :              (A_VOID);\n\n                } @{$_}\n            )\n          } @grid\n    );\n}\n\nsub move {\n\n    # Move the pen head\n    my ($y, $x) = @head_pos;\n\n    my $new_y = ($y + $dir->[0]) % $h;\n    my $new_x = ($x + $dir->[1]) % $w;\n\n    my $cell = $grid[$new_y][$new_x];\n    my $t    = $cell->[0];\n\n    # Create a new head\n    $grid[$new_y][$new_x] = [HEAD, $dir];\n\n    # Replace the current head with body\n    $grid[$y][$x] = [BODY, $dir];\n\n    # Save the position of the head\n    @head_pos = ($new_y, $new_x);\n}\n\nReadMode(3);\nwhile (1) {\n    my $key;\n    until (defined($key = ReadLine(-1))) {\n        move();\n        display();\n        sleep($sleep);\n    }\n\n    if    ($key eq \"\\e[A\") { $dir = UP }\n    elsif ($key eq \"\\e[B\") { $dir = DOWN }\n    elsif ($key eq \"\\e[C\") { $dir = RIGHT }\n    elsif ($key eq \"\\e[D\") { $dir = LEFT }\n}\n"
  },
  {
    "path": "Games/asciiplanes",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Created on: 21 August 2012\n# Latest edit on: 10 November 2013\n# https://github.com/trizen\n\n# Find the planes' positions on a grid. (text-based game)\n\nuse utf8;\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Term::ReadLine;\nuse Text::ASCIITable;\nuse List::Util qw(shuffle);\n\nbinmode(STDOUT, ':utf8');\n\nmy $DEBUG = 0;\n\n## Package variables\nmy $pkgname = 'asciiplanes';\nmy $version = 0.01;\n\n## Game run-time constants\nmy $BOARD_SIZE = 8;\nmy $PLANES_NUM = 3;\n\nmy @parts       = ('head', ('hit') x 7);\nmy @plane_chars = (shuffle('♣', '★', '✠', '❂', '☀', '❤', '❆', '❃', '▣', '▼', '■', '◉', '◆', '▲'));\n\nmy $wrap_plane = 0;\nmy $hit_char   = q{O};\nmy $miss_char  = q{`};\nmy $use_colors = eval { require Term::ANSIColor; 1; };\n\nsub usage {\n    print <<\"EOT\";\nusage: $0 [options]\n\nmain:\n        --size=i    : length side of the board (default: $BOARD_SIZE)\n        --planes=i  : the total number of planes (default: $PLANES_NUM)\n        --wrap!     : wrap the plane around the play board (default: $wrap_plane)\n        --hit=s     : character used when a plane is hit (default: \"$hit_char\")\n        --miss=s    : character used when a plane is missed (default: \"$miss_char\")\n        --planeN=s  : character used to draw the Nth killed plane (N=[1-99])\n        --colors!   : use ANSI colors (requires Term::ANSIColor) (default: $use_colors);\n\nhelp:\n        --help      : print this message and exit\n        --version   : print the version number and exit\n        --debug     : print some information useful in debugging\n\nexample:\n        $0 --size=12 --planes=6 --hit='*'\n\nEOT\n\n    exit;\n}\n\nsub version {\n    print \"$pkgname $version\\n\";\n    exit;\n}\n\nif (@ARGV) {\n    require Getopt::Long;\n    Getopt::Long::GetOptions(\n                             'board-size|size=i' => \\$BOARD_SIZE,\n                             'planes-num=i'      => \\$PLANES_NUM,\n                             'hit-char=s'        => \\$hit_char,\n                             'miss-char=s'       => \\$miss_char,\n                             'wrap!'             => \\$wrap_plane,\n                             'colors!'           => \\$use_colors,\n                             'help|h|?'          => \\&usage,\n                             'version|v|V'       => \\&version,\n                             'debug!'            => \\$DEBUG,\n                             (map { ; \"p$_|plane$_=s\" => \\$plane_chars[$_ - 1] } 1 .. 99),\n                            )\n      or die(\"$0: error in command line arguments!\\n\");\n}\n\n@plane_chars = grep { defined } @plane_chars;\n\n## The play-board of the game, and some other arrays\n#---------------------------------------------------------------\n\nmy @play_board = map { [(undef) x $BOARD_SIZE] } 1 .. $BOARD_SIZE;\nmy @info_board = map { [(q{ }) x $BOARD_SIZE] } 1 .. $BOARD_SIZE;\n\nmy %letters;\nfor (0 .. $#play_board) {\n    state $char = 'a';\n    $letters{$char++} = $_;\n}\n\n#---------------------------------------------------------------\n\nsub pointers {\n    my ($board, $x, $y, $indices) = @_;\n\n    map {\n        my ($row, $col) = ($x + $_->[0], $y + $_->[1]);\n\n        if ($wrap_plane) {\n            $row %= $BOARD_SIZE;\n            $col %= $BOARD_SIZE;\n        }\n\n        $row < $BOARD_SIZE or return;\n        $col < $BOARD_SIZE or return;\n\n        $row >= 0 or return;\n        $col >= 0 or return;\n\n        \\$board->[$row][$col]\n    }[0, 0], grep { ref($_) eq 'ARRAY' } @{$indices};\n}\n\nsub up {\n    my ($board, $x, $y) = @_;\n\n#<<<\n    return pointers($board, $x, $y, [\n                 '[+0, +0]',\n        [+1, -1], [+1, +0], [+1, +1],\n                  [+2, +0],\n        [+3, -1], [+3, +0], [+3, +1],\n    ]);\n#>>>\n}\n\nsub down {\n    my ($board, $x, $y) = @_;\n\n#<<<\n    return pointers($board, $x, $y, [\n        [-3, -1], [-3, +0], [-3, +1],\n                  [-2, +0],\n        [-1, -1], [-1, +0], [-1, +1],\n                 '[+0, +0]',\n    ]);\n#>>>\n}\n\nsub left {\n    my ($board, $x, $y) = @_;\n\n#<<<\n    return pointers($board, $x, $y, [\n                    [-1, +1],           [-1, +3],\n        '[+0, +0]', [+0, +1], [+0, +2], [+0, +3],\n                    [+1, +1],           [+1, +3],\n    ]);\n#>>>\n}\n\nsub right {\n    my ($board, $x, $y) = @_;\n\n#<<<\n    return pointers($board, $x, $y, [\n        [-1, -3],           [-1, -1],\n        [+0, -3], [+0, -2], [+0, -1], '[+0, +0]',\n        [+1, -3],           [+1, -1],\n    ]);\n#>>>\n}\n\nsub assign {\n    my %opt = @_;\n\n    my $plane = $opt{plane};\n    $#{$plane} == -1 && return;\n\n    if (not $opt{change}) {\n        foreach my $point (@{$plane}) {\n            defined(${$point}) && return;\n        }\n    }\n\n    foreach my $i (0 .. $#{$plane}) {\n        ${$plane->[$i]} = $opt{data}->[$i];\n    }\n\n    return 1;\n}\n\nsub print_ascii_table {\n    my $table = Text::ASCIITable->new({headingText => \"$pkgname $version\"});\n    $table->setCols(' ', 1 .. $BOARD_SIZE);\n\n    my $char = 'a';\n    foreach my $row (@info_board) {\n        $table->addRow([$char++, @{$row}]);\n        $table->addRowLine();\n    }\n\n    my $t = $table->drawit;\n\n    if ($use_colors) {\n        my $hit_color  = Term::ANSIColor::colored($hit_char,  \"bold red\");\n        my $miss_color = Term::ANSIColor::colored($miss_char, \"yellow\");\n\n        $t =~ s{\\Q$hit_char\\E}{$hit_color}g;\n        $t =~ s{\\Q$miss_char\\E}{$miss_color}g;\n\n        foreach my $c (@plane_chars) {\n            my $plane_color = Term::ANSIColor::colored($c, \"bold green\");\n            $t =~ s{\\Q$c\\E}{$plane_color}g;\n        }\n    }\n\n    say $t;\n}\n\nmy $count      = 0;\nmy @directions = (\\&up, \\&down, \\&left, \\&right);\n\n{\n    my $x = int rand scalar(@play_board);\n    my $y = int rand scalar(@{$play_board[0]});\n\n    my $rand = int rand scalar(@directions);\n    my $code = $directions[$rand];\n\n    assign(\n           change => 0,\n           plane  => [$code->(\\@play_board, $x, $y)],\n           data   => [map { \"$_$rand\" } @parts],\n          )\n      || redo;\n\n    if ($DEBUG) {\n        my $abc = 'a';\n        ++$abc for (1 .. $x);\n        say \"$rand: \", $abc, $y + 1;\n    }\n\n    redo if ++$count < $PLANES_NUM;\n}\n\n## MAIN\n\nmy $tries      = 0;\nmy $start_time = time;\nmy $term       = Term::ReadLine->new(\"ASCII Airplanes Game\");\n\nprint_ascii_table();\n\nwhile ($count > 0) {\n\n    print \"=>> Your guess (ex: d4)\\n\";\n    my $input = lc($term->readline(\"> \") // last);\n    last if $input eq 'q' or $input eq 'quit';\n\n    my ($letter, $y) = $input =~ /^\\h*([a-z]+)\\D*([0-9]+)/;\n\n    if (   not defined $letter\n        or not exists $letters{$letter}\n        or not defined $y\n        or $y < 1\n        or $y > $BOARD_SIZE) {\n        warn \"\\n[!] Invalid input!\\n\";\n        next;\n    }\n\n    $y -= 1;\n    ++$tries;\n\n    my $x     = $letters{$letter};\n    my $point = $play_board[$x][$y];\n\n    if (not defined $point) {\n        $info_board[$x][$y] = $miss_char;\n    }\n    elsif ($point =~ /^head(\\d)$/i) {\n        my $dir  = $1;\n        my $item = $plane_chars[($PLANES_NUM - $count) % (1 + $#plane_chars)];\n        my $code = $directions[$dir];\n\n        foreach my $board (\\@play_board, \\@info_board) {\n            assign(\n                   change => 1,\n                   data   => [($item) x 8],\n                   plane  => [$code->($board, $x, $y)],\n                  )\n              || die \"$0: unexpected error!\";\n        }\n\n        --$count;\n    }\n    elsif ($point =~ /^hit\\d$/i) {\n        $info_board[$x][$y] = $hit_char;\n    }\n}\ncontinue {\n    print_ascii_table();\n}\n\nprintf \"** Info: %d tries in %d seconds\\n\", $tries, time - $start_time;\n\nif ($count == 0) {\n    say \"** Congratulations! All the planes are destroyed!\";\n}\n"
  },
  {
    "path": "Games/snake_game.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 25 June 2015\n# Website: https://github.com/trizen\n\n# The snake game. (with colors + Unicode)\n\nuse utf8;\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Time::HiRes qw(sleep);\nuse Term::ANSIColor qw(colored);\nuse Term::ReadKey qw(ReadMode ReadLine);\n\nbinmode(STDOUT, ':utf8');\n\nuse constant {\n              VOID => 0,\n              HEAD => 1,\n              BODY => 2,\n              TAIL => 3,\n              FOOD => 4,\n             };\n\nuse constant {\n              LEFT  => [+0, -1],\n              RIGHT => [+0, +1],\n              UP    => [-1, +0],\n              DOWN  => [+1, +0],\n             };\n\nuse constant {BG_COLOR => 'on_black'};\n\nuse constant {\n              SNAKE_COLOR => ('bold green' . ' ' . BG_COLOR),\n              FOOD_COLOR  => ('red' . ' ' . BG_COLOR),\n             };\n\nuse constant {\n    U_HEAD => colored('▲', SNAKE_COLOR),\n    D_HEAD => colored('▼', SNAKE_COLOR),\n    L_HEAD => colored('◀', SNAKE_COLOR),\n    R_HEAD => colored('▶', SNAKE_COLOR),\n\n    U_BODY => colored('╹', SNAKE_COLOR),\n    D_BODY => colored('╻', SNAKE_COLOR),\n    L_BODY => colored('╴', SNAKE_COLOR),\n    R_BODY => colored('╶', SNAKE_COLOR),\n\n    U_TAIL => colored('╽', SNAKE_COLOR),\n    D_TAIL => colored('╿', SNAKE_COLOR),\n    L_TAIL => colored('╼', SNAKE_COLOR),\n    R_TAIL => colored('╾', SNAKE_COLOR),\n\n    A_VOID => colored(' ',   BG_COLOR),\n    A_FOOD => colored('❇', FOOD_COLOR),\n             };\n\nmy $sleep    = 0.05;    # sleep duration between displays\nmy $food_num = 1;       # number of initial food sources\n\nlocal $| = 1;\n\nmy $w = eval { `tput cols` }  || 80;\nmy $h = eval { `tput lines` } || 24;\nmy $r = \"\\033[H\";\n\nmy @grid = map {\n    [map { [VOID] } 1 .. $w]\n} 1 .. $h;\n\nmy $dir      = LEFT;\nmy @head_pos = ($h / 2, $w / 2);\nmy @tail_pos = ($head_pos[0], $head_pos[1] + 1);\n\n$grid[$head_pos[0]][$head_pos[1]] = [HEAD, $dir];    # head\n$grid[$tail_pos[0]][$tail_pos[1]] = [TAIL, $dir];    # tail\n\nsub create_food {\n    my ($food_x, $food_y);\n\n    do {\n        $food_x = rand($w);\n        $food_y = rand($h);\n    } while ($grid[$food_y][$food_x][0] != VOID);\n\n    $grid[$food_y][$food_x][0] = FOOD;\n}\n\ncreate_food() for (1 .. $food_num);\n\nsub display {\n    print $r, join(\n        \"\\n\",\n        map {\n            join(\n                \"\",\n                map {\n                    my $t = $_->[0];\n                    my $p = $_->[1] // '';\n\n                    my $i =\n                        $p eq UP   ? 0\n                      : $p eq DOWN ? 1\n                      : $p eq LEFT ? 2\n                      :              3;\n\n                        $t == HEAD ? (U_HEAD, D_HEAD, L_HEAD, R_HEAD)[$i]\n                      : $t == BODY ? (U_BODY, D_BODY, L_BODY, R_BODY)[$i]\n                      : $t == TAIL ? (U_TAIL, D_TAIL, L_TAIL, R_TAIL)[$i]\n                      : $t == FOOD ? (A_FOOD)\n                      :              (A_VOID);\n\n                } @{$_}\n              )\n          } @grid\n    );\n}\n\nsub move {\n    my $grew = 0;\n\n    # Move the head\n    {\n        my ($y, $x) = @head_pos;\n\n        my $new_y = ($y + $dir->[0]) % $h;\n        my $new_x = ($x + $dir->[1]) % $w;\n\n        my $cell = $grid[$new_y][$new_x];\n        my $t    = $cell->[0];\n\n        if ($t == BODY or $t == TAIL) {\n            die \"Game over!\\n\";\n        }\n        elsif ($t == FOOD) {\n            create_food();\n            $grew = 1;\n        }\n\n        # Create a new head\n        $grid[$new_y][$new_x] = [HEAD, $dir];\n\n        # Replace the current head with body\n        $grid[$y][$x] = [BODY, $dir];\n\n        # Save the position of the head\n        @head_pos = ($new_y, $new_x);\n    }\n\n    # Move the tail\n    if (not $grew) {\n        my ($y, $x) = @tail_pos;\n\n        my $pos   = $grid[$y][$x][1];\n        my $new_y = ($y + $pos->[0]) % $h;\n        my $new_x = ($x + $pos->[1]) % $w;\n\n        $grid[$y][$x][0]         = VOID;    # erase the current tail\n        $grid[$new_y][$new_x][0] = TAIL;    # create a new tail\n\n        # Save the position of the tail\n        @tail_pos = ($new_y, $new_x);\n    }\n}\n\nReadMode(3);\nwhile (1) {\n    my $key;\n    until (defined($key = ReadLine(-1))) {\n        move();\n        display();\n        sleep($sleep);\n    }\n\n    if    ($key eq \"\\e[A\" and $dir ne DOWN ) { $dir = UP    }\n    elsif ($key eq \"\\e[B\" and $dir ne UP   ) { $dir = DOWN  }\n    elsif ($key eq \"\\e[C\" and $dir ne LEFT ) { $dir = RIGHT }\n    elsif ($key eq \"\\e[D\" and $dir ne RIGHT) { $dir = LEFT  }\n}\n"
  },
  {
    "path": "Generators/bernoulli_numbers_formulas.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 21 September 2015\n# Website: https://github.com/trizen\n\nuse 5.014;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload);\n\n# Translation of:\n#   https://en.wikipedia.org/wiki/Bernoulli_number#Algorithmic_description\n\nsub bernoulli_number {\n    my ($n) = @_;\n\n    # return 0 if $n > 1 && $n % 2;    # Bn = 0 for all odd n > 1\n\n    my @A;\n    for my $m (0 .. $n) {\n        $A[$m] = 1 / ($m + 1);\n\n        for (my $j = $m ; $j > 0 ; $j--) {\n            $A[$j - 1] = ((($j == 1 ? '' : \"$j*\") . '(' . join('-', ($A[$j - 1], $A[$j])) . ')') =~ s/^\\((.*?)\\)\\z/$1/r);\n        }\n    }\n\n    return $A[0];    # which is Bn\n}\n\nforeach my $i (0 .. 6) {\n    printf(\"B(%d) = %s\\n\", $i, bernoulli_number($i));\n}\n\n__END__\nB(0) = 1\nB(1) = 1-1/2\nB(2) = 1-1/2-2*(1/2-1/3)\nB(3) = 1-1/2-2*(1/2-1/3)-2*(2*(1/2-1/3)-3*(1/3-1/4))\nB(4) = 1-1/2-2*(1/2-1/3)-2*(2*(1/2-1/3)-3*(1/3-1/4))-2*(2*(2*(1/2-1/3)-3*(1/3-1/4))-3*(3*(1/3-1/4)-4*(1/4-1/5)))\nB(5) = 1-1/2-2*(1/2-1/3)-2*(2*(1/2-1/3)-3*(1/3-1/4))-2*(2*(2*(1/2-1/3)-3*(1/3-1/4))-3*(3*(1/3-1/4)-4*(1/4-1/5)))-2*(2*(2*(2*(1/2-1/3)-3*(1/3-1/4))-3*(3*(1/3-1/4)-4*(1/4-1/5)))-3*(3*(3*(1/3-1/4)-4*(1/4-1/5))-4*(4*(1/4-1/5)-5*(1/5-1/6))))\nB(6) = 1-1/2-2*(1/2-1/3)-2*(2*(1/2-1/3)-3*(1/3-1/4))-2*(2*(2*(1/2-1/3)-3*(1/3-1/4))-3*(3*(1/3-1/4)-4*(1/4-1/5)))-2*(2*(2*(2*(1/2-1/3)-3*(1/3-1/4))-3*(3*(1/3-1/4)-4*(1/4-1/5)))-3*(3*(3*(1/3-1/4)-4*(1/4-1/5))-4*(4*(1/4-1/5)-5*(1/5-1/6))))-2*(2*(2*(2*(2*(1/2-1/3)-3*(1/3-1/4))-3*(3*(1/3-1/4)-4*(1/4-1/5)))-3*(3*(3*(1/3-1/4)-4*(1/4-1/5))-4*(4*(1/4-1/5)-5*(1/5-1/6))))-3*(3*(3*(3*(1/3-1/4)-4*(1/4-1/5))-4*(4*(1/4-1/5)-5*(1/5-1/6)))-4*(4*(4*(1/4-1/5)-5*(1/5-1/6))-5*(5*(1/5-1/6)-6*(1/6-1/7)))))\n"
  },
  {
    "path": "Generators/faulhaber_s_formula_symbolic.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 10 February 2016\n# Website: https://github.com/trizen\n\n# The script generates formulas for calculating the sum\n# of consecutive numbers raised to a given power, such as:\n#    1^p + 2^p + 3^p + ... + n^p\n# where p is a positive integer.\n\n# See also: https://en.wikipedia.org/wiki/Faulhaber%27s_formula\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::Algebra::Symbols;\n\n# This function returns the nth Bernoulli number\n# See: https://en.wikipedia.org/wiki/Bernoulli_number\nsub bernoulli_number {\n    my ($n) = @_;\n\n    return 0 if $n > 1 && $n % 2;    # Bn = 0 for all odd n > 1\n\n    my @A;\n    for my $m (0 .. $n) {\n        $A[$m] = symbols(1) / ($m + 1);\n\n        for (my $j = $m ; $j > 0 ; $j--) {\n            $A[$j - 1] = $j * ($A[$j - 1] - $A[$j]);\n        }\n    }\n\n    return $A[0];                    # which is Bn\n}\n\n# The binomial coefficient\n# See: https://en.wikipedia.org/wiki/Binomial_coefficient\nsub binomial {\n    my ($n, $k) = @_;\n    $k == 0 || $n == $k ? 1 : binomial($n-1, $k-1) + binomial($n-1, $k);\n}\n\n# The Faulhaber's formula\n# See: https://en.wikipedia.org/wiki/Faulhaber%27s_formula\nsub faulhaber_s_formula {\n    my ($p) = @_;\n\n    my $formula = 0;\n    for my $j (0 .. $p) {\n        $formula += (binomial($p + 1, $j) * bernoulli_number($j)) * symbols('n')**($p + 1 - $j);\n    }\n\n    (symbols(1) / ($p+1) * $formula) =~ s/\\$n/n/gr =~ s/\\*\\*/^/gr;\n}\n\nforeach my $i (0 .. 10) {\n    say \"$i: \", faulhaber_s_formula($i);\n}\n"
  },
  {
    "path": "Generators/faulhaber_s_formulas_expanded.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 21 September 2015\n# Website: https://github.com/trizen\n\n# The script generates formulas for calculating the sum\n# of consecutive numbers raised to a given power, such as:\n#    1^p + 2^p + 3^p + ... + n^p\n# where p is a positive integer.\n\n# See also: https://en.wikipedia.org/wiki/Faulhaber%27s_formula\n\n# To simplify the formulas, use Wolfram Alpha:\n# https://www.wolframalpha.com/\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Memoize qw( memoize );\n\nmemoize('binomial');\nmemoize('factorial');\nmemoize('bern_helper');\nmemoize('bernoulli_number');\n\n# Factorial\n# See: https://en.wikipedia.org/wiki/Factorial\nsub factorial {\n    my ($n) = @_;\n\n    return 1 if $n == 0;\n\n    my $f = $n;\n    while ($n-- > 1) {\n        $f = \"$f*$n\";\n    }\n\n    return $f;\n}\n\n# Binomial coefficient\n# See: https://en.wikipedia.org/wiki/Binomial_coefficient\nsub binomial {\n    my ($n, $k) = @_;\n\n    ## This line expands the factorials\n    #return \"(\".factorial($n) .\")\" . \"/((\" . factorial($k).\")*(\". factorial($n-$k) . \"))\";\n\n    ## This line expands the binomial coefficients into factorials\n    return \"$n!/($k!*\" . ($n - $k) . \"!)\";\n\n    ## This line computes the binomial coefficients\n    #$k == 0 || $n == $k ? 1.0 : binomial($n - 1, $k - 1) + binomial($n - 1, $k);\n}\n\n# Bernoulli numbers\n# See: https://en.wikipedia.org/wiki/Bernoulli_number#Recursive_definition\nsub bern_helper {\n    my ($n, $k) = @_;\n    binomial($n, $k) . \"*(\" . (bernoulli_number($k) . \"/\" . ($n - $k + 1)) . \")\";\n}\n\nsub bern_diff {\n    my ($n, $k, $d) = @_;\n    $n < $k ? $d : bern_diff($n, $k + 1, \"($d-\" . bern_helper($n + 1, $k) . \")\");\n}\n\nsub bernoulli_number {\n    my ($n) = @_;\n    $n > 0 ? bern_diff($n - 1, 0, 1.0) : 1.0;\n}\n\n# Faulhaber's formula\n# See: https://en.wikipedia.org/wiki/Faulhaber%27s_formula\nsub faulhaber_s_formula {\n    my ($p, $n) = @_;\n\n    my @formula;\n    for my $j (0 .. $p) {\n        push @formula, ('(' . (binomial($p + 1, $j) . \"*\" . bernoulli_number($j)) . ')') . '*' . \"n^\" . ($p + 1 - $j);\n    }\n\n    my $formula = join(' + ', @formula);\n    \"1/\" . ($p + 1) . \" * ($formula)\";\n}\n\nfor my $i (0 .. 5) {\n    printf \"%d => %s\\n\", $i, faulhaber_s_formula($i + 0);\n}\n\n__END__\n0 => 1/1 * ((1!/(0!*1!)*1)*n^1)\n1 => 1/2 * ((2!/(0!*2!)*1)*n^2 + (2!/(1!*1!)*(1-1!/(0!*1!)*(1/2)))*n^1)\n2 => 1/3 * ((3!/(0!*3!)*1)*n^3 + (3!/(1!*2!)*(1-1!/(0!*1!)*(1/2)))*n^2 + (3!/(2!*1!)*((1-2!/(0!*2!)*(1/3))-2!/(1!*1!)*((1-1!/(0!*1!)*(1/2))/2)))*n^1)\n3 => 1/4 * ((4!/(0!*4!)*1)*n^4 + (4!/(1!*3!)*(1-1!/(0!*1!)*(1/2)))*n^3 + (4!/(2!*2!)*((1-2!/(0!*2!)*(1/3))-2!/(1!*1!)*((1-1!/(0!*1!)*(1/2))/2)))*n^2 + (4!/(3!*1!)*(((1-3!/(0!*3!)*(1/4))-3!/(1!*2!)*((1-1!/(0!*1!)*(1/2))/3))-3!/(2!*1!)*(((1-2!/(0!*2!)*(1/3))-2!/(1!*1!)*((1-1!/(0!*1!)*(1/2))/2))/2)))*n^1)\n4 => 1/5 * ((5!/(0!*5!)*1)*n^5 + (5!/(1!*4!)*(1-1!/(0!*1!)*(1/2)))*n^4 + (5!/(2!*3!)*((1-2!/(0!*2!)*(1/3))-2!/(1!*1!)*((1-1!/(0!*1!)*(1/2))/2)))*n^3 + (5!/(3!*2!)*(((1-3!/(0!*3!)*(1/4))-3!/(1!*2!)*((1-1!/(0!*1!)*(1/2))/3))-3!/(2!*1!)*(((1-2!/(0!*2!)*(1/3))-2!/(1!*1!)*((1-1!/(0!*1!)*(1/2))/2))/2)))*n^2 + (5!/(4!*1!)*((((1-4!/(0!*4!)*(1/5))-4!/(1!*3!)*((1-1!/(0!*1!)*(1/2))/4))-4!/(2!*2!)*(((1-2!/(0!*2!)*(1/3))-2!/(1!*1!)*((1-1!/(0!*1!)*(1/2))/2))/3))-4!/(3!*1!)*((((1-3!/(0!*3!)*(1/4))-3!/(1!*2!)*((1-1!/(0!*1!)*(1/2))/3))-3!/(2!*1!)*(((1-2!/(0!*2!)*(1/3))-2!/(1!*1!)*((1-1!/(0!*1!)*(1/2))/2))/2))/2)))*n^1)\n5 => 1/6 * ((6!/(0!*6!)*1)*n^6 + (6!/(1!*5!)*(1-1!/(0!*1!)*(1/2)))*n^5 + (6!/(2!*4!)*((1-2!/(0!*2!)*(1/3))-2!/(1!*1!)*((1-1!/(0!*1!)*(1/2))/2)))*n^4 + (6!/(3!*3!)*(((1-3!/(0!*3!)*(1/4))-3!/(1!*2!)*((1-1!/(0!*1!)*(1/2))/3))-3!/(2!*1!)*(((1-2!/(0!*2!)*(1/3))-2!/(1!*1!)*((1-1!/(0!*1!)*(1/2))/2))/2)))*n^3 + (6!/(4!*2!)*((((1-4!/(0!*4!)*(1/5))-4!/(1!*3!)*((1-1!/(0!*1!)*(1/2))/4))-4!/(2!*2!)*(((1-2!/(0!*2!)*(1/3))-2!/(1!*1!)*((1-1!/(0!*1!)*(1/2))/2))/3))-4!/(3!*1!)*((((1-3!/(0!*3!)*(1/4))-3!/(1!*2!)*((1-1!/(0!*1!)*(1/2))/3))-3!/(2!*1!)*(((1-2!/(0!*2!)*(1/3))-2!/(1!*1!)*((1-1!/(0!*1!)*(1/2))/2))/2))/2)))*n^2 + (6!/(5!*1!)*(((((1-5!/(0!*5!)*(1/6))-5!/(1!*4!)*((1-1!/(0!*1!)*(1/2))/5))-5!/(2!*3!)*(((1-2!/(0!*2!)*(1/3))-2!/(1!*1!)*((1-1!/(0!*1!)*(1/2))/2))/4))-5!/(3!*2!)*((((1-3!/(0!*3!)*(1/4))-3!/(1!*2!)*((1-1!/(0!*1!)*(1/2))/3))-3!/(2!*1!)*(((1-2!/(0!*2!)*(1/3))-2!/(1!*1!)*((1-1!/(0!*1!)*(1/2))/2))/2))/3))-5!/(4!*1!)*(((((1-4!/(0!*4!)*(1/5))-4!/(1!*3!)*((1-1!/(0!*1!)*(1/2))/4))-4!/(2!*2!)*(((1-2!/(0!*2!)*(1/3))-2!/(1!*1!)*((1-1!/(0!*1!)*(1/2))/2))/3))-4!/(3!*1!)*((((1-3!/(0!*3!)*(1/4))-3!/(1!*2!)*((1-1!/(0!*1!)*(1/2))/3))-3!/(2!*1!)*(((1-2!/(0!*2!)*(1/3))-2!/(1!*1!)*((1-1!/(0!*1!)*(1/2))/2))/2))/2))/2)))*n^1)\n"
  },
  {
    "path": "Generators/faulhaber_s_formulas_expanded_2.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 21 September 2015\n# Website: https://github.com/trizen\n\n# The script generates formulas for calculating the sum\n# of consecutive numbers raised to a given power, such as:\n#    1^p + 2^p + 3^p + ... + n^p\n# where p is a positive integer.\n\n# See also: https://en.wikipedia.org/wiki/Faulhaber%27s_formula\n\n# To simplify the formulas, use Wolfram Alpha:\n# https://www.wolframalpha.com/\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload);\nuse Memoize qw( memoize );\n\nmemoize('binomial');\nmemoize('factorial');\nmemoize('bernoulli_number');\n\n# Factorial\n# See: https://en.wikipedia.org/wiki/Factorial\nsub factorial {\n    my ($n) = @_;\n\n    return 1 if $n == 0;\n\n    my $f = $n;\n    while ($n-- > 1) {\n        $f = \"$f*$n\";\n    }\n\n    return $f;\n}\n\n# Binomial coefficient\n# See: https://en.wikipedia.org/wiki/Binomial_coefficient\nsub binomial {\n    my ($n, $k) = @_;\n\n    ## This line expands the factorials\n    #return \"(\".factorial($n) .\")\" . \"/((\" . factorial($k).\")*(\". factorial($n-$k) . \"))\";\n\n    ## This line expands the binomial coefficients into factorials\n    return \"$n!/($k!*\" . ($n - $k) . \"!)\";\n\n    ## This line computes the binomial coefficients\n    #$k == 0 || $n == $k ? 1.0 : binomial($n - 1, $k - 1) + binomial($n - 1, $k);\n}\n\n# Bernoulli numbers\n# See: https://en.wikipedia.org/wiki/Bernoulli_number#Algorithmic_description\nsub bernoulli_number {\n    my ($n) = @_;\n\n    # return 0 if $n > 1 && $n % 2;    # Bn = 0 for all odd n > 1\n\n    my @A;\n    for my $m (0 .. $n) {\n        $A[$m] = 1 / ($m + 1);\n        for (my $j = $m ; $j > 0 ; $j--) {\n            $A[$j - 1] = \"$j*\" . '(' . join('-', ($A[$j - 1], $A[$j])) . ')';\n        }\n    }\n\n    return $A[0];    # which is Bn\n}\n\n# Faulhaber's formula\n# See: https://en.wikipedia.org/wiki/Faulhaber%27s_formula\nsub faulhaber_s_formula {\n    my ($p, $n) = @_;\n\n    my @formula;\n    for my $j (0 .. $p) {\n        push @formula, ('(' . (binomial($p + 1, $j) . \"*\" . bernoulli_number($j)) . ')') . '*' . \"n^\" . ($p + 1 - $j);\n    }\n\n    my $formula = join(' + ', @formula);\n    \"1/\" . ($p + 1) . \" * ($formula)\";\n}\n\nfor my $i (0 .. 5) {\n    printf \"%d => %s\\n\", $i, faulhaber_s_formula($i + 0);\n}\n\n__END__\n0 => 1/1 * ((1!/(0!*1!)*1)*n^1)\n1 => 1/2 * ((2!/(0!*2!)*1)*n^2 + (2!/(1!*1!)*1*(1-1/2))*n^1)\n2 => 1/3 * ((3!/(0!*3!)*1)*n^3 + (3!/(1!*2!)*1*(1-1/2))*n^2 + (3!/(2!*1!)*1*(1*(1-1/2)-2*(1/2-1/3)))*n^1)\n3 => 1/4 * ((4!/(0!*4!)*1)*n^4 + (4!/(1!*3!)*1*(1-1/2))*n^3 + (4!/(2!*2!)*1*(1*(1-1/2)-2*(1/2-1/3)))*n^2 + (4!/(3!*1!)*1*(1*(1*(1-1/2)-2*(1/2-1/3))-2*(2*(1/2-1/3)-3*(1/3-1/4))))*n^1)\n4 => 1/5 * ((5!/(0!*5!)*1)*n^5 + (5!/(1!*4!)*1*(1-1/2))*n^4 + (5!/(2!*3!)*1*(1*(1-1/2)-2*(1/2-1/3)))*n^3 + (5!/(3!*2!)*1*(1*(1*(1-1/2)-2*(1/2-1/3))-2*(2*(1/2-1/3)-3*(1/3-1/4))))*n^2 + (5!/(4!*1!)*1*(1*(1*(1*(1-1/2)-2*(1/2-1/3))-2*(2*(1/2-1/3)-3*(1/3-1/4)))-2*(2*(2*(1/2-1/3)-3*(1/3-1/4))-3*(3*(1/3-1/4)-4*(1/4-1/5)))))*n^1)\n5 => 1/6 * ((6!/(0!*6!)*1)*n^6 + (6!/(1!*5!)*1*(1-1/2))*n^5 + (6!/(2!*4!)*1*(1*(1-1/2)-2*(1/2-1/3)))*n^4 + (6!/(3!*3!)*1*(1*(1*(1-1/2)-2*(1/2-1/3))-2*(2*(1/2-1/3)-3*(1/3-1/4))))*n^3 + (6!/(4!*2!)*1*(1*(1*(1*(1-1/2)-2*(1/2-1/3))-2*(2*(1/2-1/3)-3*(1/3-1/4)))-2*(2*(2*(1/2-1/3)-3*(1/3-1/4))-3*(3*(1/3-1/4)-4*(1/4-1/5)))))*n^2 + (6!/(5!*1!)*1*(1*(1*(1*(1*(1-1/2)-2*(1/2-1/3))-2*(2*(1/2-1/3)-3*(1/3-1/4)))-2*(2*(2*(1/2-1/3)-3*(1/3-1/4))-3*(3*(1/3-1/4)-4*(1/4-1/5))))-2*(2*(2*(2*(1/2-1/3)-3*(1/3-1/4))-3*(3*(1/3-1/4)-4*(1/4-1/5)))-3*(3*(3*(1/3-1/4)-4*(1/4-1/5))-4*(4*(1/4-1/5)-5*(1/5-1/6))))))*n^1)\n"
  },
  {
    "path": "Generators/faulhaber_s_formulas_generator.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 03 September 2015\n# Website: https://github.com/trizen\n\n# The script generates formulas for calculating the sum\n# of consecutive numbers raised to a given power, such as:\n#    1^p + 2^p + 3^p + ... + n^p\n# where p is a positive integer.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Faulhaber%27s_formula\n\n# For simplifying the formulas, we can use Wolfram|Alpha:\n#   https://www.wolframalpha.com/\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload binomial);\n\n# This function returns the nth Bernoulli number\n# See: https://en.wikipedia.org/wiki/Bernoulli_number\nsub bernoulli_number {\n    my ($n) = @_;\n\n    return 0 if $n > 1 && $n % 2;    # Bn = 0 for all odd n > 1\n\n    my @A;\n    for my $m (0 .. $n) {\n        $A[$m] = 1 / ($m + 1);\n\n        for (my $j = $m ; $j > 0 ; $j--) {\n            $A[$j - 1] = $j * ($A[$j - 1] - $A[$j]);\n        }\n    }\n\n    return $A[0];                    # which is Bn\n}\n\n# The Faulhaber's formula\n# See: https://en.wikipedia.org/wiki/Faulhaber%27s_formula\nsub faulhaber_s_formula {\n    my ($p) = @_;\n\n    my @formula;\n    for my $j (0 .. $p) {\n        push @formula, ('(' . (binomial($p + 1, $j) * bernoulli_number($j)) . ')') . '*' . \"n^\" . ($p + 1 - $j);\n    }\n\n    my $formula = join(' + ', grep { !/\\(0\\)\\*/ } @formula);\n\n    $formula =~ s{\\(1\\)\\*}{}g;\n    $formula =~ s{\\^1\\b}{}g;\n\n    \"1/\" . ($p + 1) . \" * ($formula)\";\n}\n\nforeach my $i (0 .. 10) {\n    say \"$i: \", faulhaber_s_formula($i);\n}\n\n__END__\n0: 1/1 * (n)\n1: 1/2 * (n^2 + n)\n2: 1/3 * (n^3 + (3/2)*n^2 + (1/2)*n)\n3: 1/4 * (n^4 + (2)*n^3 + n^2)\n4: 1/5 * (n^5 + (5/2)*n^4 + (5/3)*n^3 + (-1/6)*n)\n5: 1/6 * (n^6 + (3)*n^5 + (5/2)*n^4 + (-1/2)*n^2)\n6: 1/7 * (n^7 + (7/2)*n^6 + (7/2)*n^5 + (-7/6)*n^3 + (1/6)*n)\n7: 1/8 * (n^8 + (4)*n^7 + (14/3)*n^6 + (-7/3)*n^4 + (2/3)*n^2)\n8: 1/9 * (n^9 + (9/2)*n^8 + (6)*n^7 + (-21/5)*n^5 + (2)*n^3 + (-3/10)*n)\n9: 1/10 * (n^10 + (5)*n^9 + (15/2)*n^8 + (-7)*n^6 + (5)*n^4 + (-3/2)*n^2)\n10: 1/11 * (n^11 + (11/2)*n^10 + (55/6)*n^9 + (-11)*n^7 + (11)*n^5 + (-11/2)*n^3 + (5/6)*n)\n"
  },
  {
    "path": "Generators/parsing_and_code_gen.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 21 December 2015\n# Website: https://github.com/trizen\n\n# A very basic parser and a Perl code generator.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\n#\n## The parser\n#\n\nsub parse_expr {\n    local *_ = $_[0];\n\n    # Whitespace\n    /\\G\\s+/gc;\n\n    # Number\n    if (/\\G([-+]?[0-9]+(?:\\.[0-9]+)?)\\b/gc) {\n        return bless {value => $1}, 'Number';\n    }\n\n    # Variable declaration\n    if (/\\Gvar\\b/gc) {\n        /\\G\\s+(\\w+)/gc || die \"expected a variable name after `var`\";\n        return bless {name => $1}, 'Variable';\n    }\n\n    # Identifier\n    if (/\\G(\\w+)/gc) {\n        return bless {name => $1}, 'Identifier';\n    }\n\n    # Nested expression\n    if (/\\G\\(/gc) {\n        return parse($_[0]);\n    }\n\n    return;\n}\n\nsub parse {\n    local *_ = $_[0];\n\n    my %ast;\n    while (1) {\n        /\\G\\s+/gc;\n\n        # Prefix operator\n        if (/\\Gsay\\b/gc) {\n            my $arg = parse_expr($_[0]);\n            push @{$ast{main}}, {self => bless({expr => {self => $arg}}, 'Say')};\n        }\n\n        # Expression\n        my $expr = parse_expr($_[0]);\n        if (defined $expr) {\n            push @{$ast{main}}, {self => $expr};\n\n            # Binary operator\n            while (m{\\G\\s*([-\\^+*/=])}gc) {\n                my $op = $1;\n\n                # Expression\n                my $arg = parse_expr($_[0]);\n                push @{$ast{main}[-1]{call}}, {op => $op, arg => {self => $arg}};\n            }\n\n            next;\n        }\n\n        # End of nested expression\n        if (/\\G\\)/gc) {\n            return \\%ast;\n        }\n\n        # End of code\n        if (/\\G\\z/gc) {\n            return \\%ast;\n        }\n\n        die \"Syntax error at -->\", substr($_, pos($_), 10) . \"\\n\",;\n    }\n\n    return \\%ast;\n}\n\n#\n## The code generator\n#\n\nsub generate_expr {\n    my ($expr) = @_;\n\n    my $code = '';\n    my $obj  = $expr->{self};\n\n    my $ref = ref($obj);\n    if ($ref eq 'HASH') {\n        $code = '(' . generate($obj) . ')';\n    }\n    elsif ($ref eq 'Number') {\n        $code = $obj->{value};\n    }\n    elsif ($ref eq 'Variable') {\n        $code = 'my $' . $obj->{name};\n    }\n    elsif ($ref eq 'Identifier') {\n        $code = '$' . $obj->{name};\n    }\n    elsif ($ref eq 'Say') {\n        $code = 'print(' . generate_expr($obj->{expr}) . ', \"\\n\")';\n    }\n\n    # Check for a call operator\n    if (exists $expr->{call}) {\n        foreach my $call (@{$expr->{call}}) {\n            if (exists $call->{op}) {\n                my $op = $call->{op};\n                $code .= ' ';\n                if ($op eq '^') {\n                    $code .= '**';\n                }\n                else {\n                    $code .= $op;\n                }\n                $code .= ' ';\n            }\n            if (exists $call->{arg}) {\n                $code .= generate_expr($call->{arg});\n            }\n        }\n    }\n\n    return $code;\n}\n\nsub generate {\n    my ($ast) = @_;\n\n    my @statements;\n    foreach my $statement (@{$ast->{main}}) {\n        push @statements, generate_expr($statement);\n    }\n\n    return join(\";\\n\", @statements);\n}\n\n#\n## Example\n#\n\nmy $code = <<'EOT';\nvar x = 42\nvar y = (81 / 3)\nsay (x^2 * (3+y) - 1)\nEOT\n\nmy $ast = parse(\\$code);    # parses the code and returns the AST\neval {\n    require Data::Dump;\n    Data::Dump::pp($ast);    # displays the AST (if Data::Dump is installed)\n};\n\nsay generate($ast);          # generates code from the AST and prints it\n"
  },
  {
    "path": "Generators/powers_of_factorial.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 18 July 2016\n# Website: https://github.com/trizen\n\n# A shortcut algorithm for finding the prime powers of n!\n# without computing the n-factorial in the first place.\n\n# Example:\n#  6! is equal with: 2^4 * 3^2 * 5\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(forprimes vecsum todigits);\n\nsub factorial_power ($n, $p) {\n    ($n - vecsum(todigits($n, $p))) / ($p - 1);\n}\n\nsub factorial_powers ($n) {\n\n    my $p = 0;\n    my @powers;\n\n    forprimes {\n        if ($p == 1) {\n            push @powers, $_;\n        }\n        else {\n            push @powers, ($p = factorial_power($n, $_)) == 1 ? $_ : \"$_^$p\";\n        }\n    } $n;\n\n    @powers ? join(' * ', @powers) : '1';\n}\n\nfor (0 .. 25) {\n    say \"$_! = \", factorial_powers($_);\n}\n\n__END__\n0! = 1\n1! = 1\n2! = 2\n3! = 2 * 3\n4! = 2^3 * 3\n5! = 2^3 * 3 * 5\n6! = 2^4 * 3^2 * 5\n7! = 2^4 * 3^2 * 5 * 7\n8! = 2^7 * 3^2 * 5 * 7\n9! = 2^7 * 3^4 * 5 * 7\n10! = 2^8 * 3^4 * 5^2 * 7\n11! = 2^8 * 3^4 * 5^2 * 7 * 11\n12! = 2^10 * 3^5 * 5^2 * 7 * 11\n13! = 2^10 * 3^5 * 5^2 * 7 * 11 * 13\n14! = 2^11 * 3^5 * 5^2 * 7^2 * 11 * 13\n15! = 2^11 * 3^6 * 5^3 * 7^2 * 11 * 13\n16! = 2^15 * 3^6 * 5^3 * 7^2 * 11 * 13\n17! = 2^15 * 3^6 * 5^3 * 7^2 * 11 * 13 * 17\n18! = 2^16 * 3^8 * 5^3 * 7^2 * 11 * 13 * 17\n19! = 2^16 * 3^8 * 5^3 * 7^2 * 11 * 13 * 17 * 19\n20! = 2^18 * 3^8 * 5^4 * 7^2 * 11 * 13 * 17 * 19\n21! = 2^18 * 3^9 * 5^4 * 7^3 * 11 * 13 * 17 * 19\n22! = 2^19 * 3^9 * 5^4 * 7^3 * 11^2 * 13 * 17 * 19\n23! = 2^19 * 3^9 * 5^4 * 7^3 * 11^2 * 13 * 17 * 19 * 23\n24! = 2^22 * 3^10 * 5^4 * 7^3 * 11^2 * 13 * 17 * 19 * 23\n25! = 2^22 * 3^10 * 5^6 * 7^3 * 11^2 * 13 * 17 * 19 * 23\n"
  },
  {
    "path": "Generators/random_lsystem_generator.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 09 May 2016\n# Website: https://github.com/trizen\n\n# Generate a random L-System.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload is_power);\nuse ntheory qw(is_prime factor);\n\nmy @vars = ('F', 'G', 'H');\n\nsub is_triangular {\n    my ($x) = @_;\n    int(sqrt(8 * $x + 1))**2 == (8 * $x + 1);\n}\n\nsub is_square {\n    my ($x) = @_;\n    int(sqrt($x))**2 == $x;\n}\n\nsub divide {\n    my ($str, $i) = @_;\n\n    my @parts = ($str);\n\n    for (1 .. @vars - 1) {\n        my $rand;\n\n        my $i     = int(rand(@parts));\n        my $part  = $parts[$i];\n        my $count = 0;\n\n        do {\n            $rand = int(rand(length($part)));\n            if (++$count > 10) {\n                generate();\n                return;\n            }\n          } while (\n            do {\n                my $s = substr($part, 0, $rand);\n                ($s =~ tr/[//) != ($s =~ tr/]//);\n            }\n          );\n\n        my ($x, $y) = (substr($part, 0, $rand), substr($part, $rand));\n        splice(@parts, $i, 1, $x, $y);\n    }\n\n    foreach my $part (@parts) {\n        if (\n            $part eq ''\n            or not $part =~ /\\w/\n\n            # TODO: check each path (not only the first one)\n            or (($parts[0] =~ tr/A-Z//cdsr) =~ /^$vars[0]+\\z/o\n                and @vars > 1)\n          ) {\n            $i ||= 0;\n            if ($i < 10) {\n                return divide($str, $i + 1);\n            }\n            else {\n                generate();\n                return;\n            }\n        }\n    }\n\n    return @parts;\n}\n\nsub generate {\n\n    my $start     = int(rand(1000)) + 0;\n    my $limit     = $start + 10;\n    my $deviation = 50;\n\n    my @open;\n    my $str = '';\n\n    for (\n        my $n = $start ;\n        $n <= $limit ? 1 : @open ? do {\n            $limit += 1;\n            if ($limit - $start > $deviation) { return generate() }\n            1;\n        }\n        : 0 ; $n++\n      ) {\n\n        if (is_triangular($n) or is_square($n)) {\n            for (1 .. rand(5)) {\n                $str .= ('+', '-')[rand(2)];\n            }\n        }\n\n        if (is_prime($n) or is_power($n)) {\n            if (@open and rand(1) < 0.5) {\n                $str .= ']';\n                pop @open;\n            }\n            else {\n                $str .= '[';\n                push @open, 1;\n            }\n        }\n\n        for (1 .. rand(5)) {\n            if (rand(1) < 0.5) {\n                $str .= $vars[rand @vars];\n            }\n        }\n\n        if (rand(1) < 0.5) {\n            $str .= ('+', '-')[rand(2)];\n        }\n    }\n\n    my @parts = divide($str);\n    foreach my $i (0 .. $#parts) {\n        say \"$vars[$i] => \\\"$parts[$i]\\\",\";\n    }\n}\n\ngenerate();\n"
  },
  {
    "path": "Generators/semiprime_equationization_C_generator.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 10 July 2015\n# Website: https://github.com/trizen\n\n# Generate a C program to compute the prime factors of a semiprime number.\n\nuse 5.016;\nuse strict;\nuse integer;\nuse warnings;\n\nsub semiprime_equationization {\n    my ($semiprime, $xlen, $ylen) = @_;\n\n    $xlen -= 1;\n    $ylen -= 1;\n\n    my @map;\n    my @result;\n    my $mem = '0';\n\n    my %x_loops;\n    foreach my $i (0 .. $xlen) {\n        my $start = $i == $xlen ? 1 : 0;\n        $x_loops{\"x$i\"} = \"for (unsigned int x$i = $start; x$i < 10; ++x$i) {\";\n    }\n\n    my %y_loops;\n    foreach my $i (0 .. $ylen) {\n        my $start = $i == $ylen ? 1 : 0;\n        $y_loops{\"y$i\"} = \"for (unsigned int y$i = $start; y$i < 10; ++y$i) {\";\n    }\n\n    my %vars;\n    foreach my $j (0 .. $ylen) {\n        foreach my $i (0 .. $xlen) {\n            my $expr = '(' . join(' + ', \"(x$i * y$j)\", grep { $_ ne '0' } $mem) . ')';\n\n            $vars{\"xy$i$j\"} = $expr;\n            my $n = \"xy$i$j\";\n\n            if ($i == $xlen) {\n                push @{$map[$j]}, \"($n % 10)\", \"($n / 10)\";\n                $mem = '0';\n            }\n            else {\n                push @{$map[$j]}, \"($n % 10)\";\n                $mem = \"($n / 10)\";\n            }\n        }\n\n        my $n = $ylen - $j;\n        if ($n > 0) {\n            push @{$map[$j]}, ((0) x $n);\n        }\n\n        my $m = $ylen - $n;\n        if ($m > 0) {\n            unshift @{$map[$j]}, ((0) x $m);\n        }\n    }\n\n    my @number = reverse split //, $semiprime;\n\n    my @mrange = (0 .. $#map);\n    my $end    = $xlen + $ylen + 1;\n\n    my %seen;\n    my $loop_init = sub {\n        my ($str) = @_;\n        while ($str =~ /\\b(y\\d+)/g) {\n            if (not $seen{$1}++) {\n                my $init = $y_loops{$1};\n                push @result, $init;\n            }\n        }\n        while ($str =~ /\\b(x\\d+)/g) {\n            if (not $seen{$1}++) {\n                my $init = $x_loops{$1};\n                push @result, $init;\n            }\n        }\n    };\n\n    my $initializer = sub {\n        my ($str) = @_;\n        $loop_init->($str);\n        while ($str =~ /\\b(xy\\d+)/g) {\n            if (not $seen{$1}++) {\n                my $init = \"const unsigned int $1 = $vars{$1};\";\n                __SUB__->($init);\n                push @result, $init;\n            }\n        }\n    };\n\n    foreach my $i (0 .. $#number) {\n        my $expr = '(' . join(' + ', grep { $_ ne '0' } (map { $map[$_][$i] } @mrange), $mem) . ')';\n        $initializer->($expr);\n\n        push @result, \"const unsigned int n$i = $expr;\";\n        my $n = \"n$i\";\n\n        if ($i == $#number) {\n            push @result,\n                qq/if ($number[$i] == $n) { printf(\"Cracked: /\n              . (\"%d\" x ($xlen + 1))\n              . (\" * \")\n              . (\"%d\" x ($ylen + 1))\n              . qq/\\\\n\", /\n              . join(\", \", (map { \"x$_\" } reverse(0 .. $xlen)), (map { \"y$_\" } reverse(0 .. $ylen)))\n              . qq/); return 0; }/;\n        }\n        elsif ($i == 0) {\n            push @result, \"if ($number[$i] != $n) { continue; }\";\n            $mem = '0';\n        }\n        else {\n            push @result, \"if ($number[$i] != ($n % 10)) { continue; }\";\n            $mem = \"($n / 10)\";\n        }\n    }\n\n    unshift @result, \"#include <stdio.h>\", \"int main() {\";\n    push @result, \"}\" x (1 + $xlen + 1 + $ylen + 1);\n\n    return @result;\n}\n\n# 71 * 43\n#say for semiprime_equationization('3053', 2, 2);\n\n# 251 * 197\n#say for semiprime_equationization('49447', 3, 3);\n\n# 7907 * 4999\nsay for semiprime_equationization('39527093', 4, 4);\n\n# 472882049 * 472882049\n#say for semiprime_equationization('223617432266438401', 9, 9);\n\n# 37975227936943673922808872755445627854565536638199 * 40094690950920881030683735292761468389214899724061\n#say for semiprime_equationization('1522605027922533360535618378132637429718068114961380688657908494580122963258952897654000350692006139', 50, 50);\n"
  },
  {
    "path": "Generators/semiprime_equationization_Perl_generator.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 10 July 2015\n# Website: https://github.com/trizen\n\n# Generate a Perl program to compute the prime factors of a semiprime number.\n\nuse 5.016;\nuse strict;\nuse integer;\nuse warnings;\n\nsub semiprime_equationization {\n    my ($semiprime, $xlen, $ylen) = @_;\n\n    $xlen -= 1;\n    $ylen -= 1;\n\n    my @map;\n    my @result;\n    my $mem = '0';\n\n    my %x_loops;\n    foreach my $i (0 .. $xlen) {\n        my $start = $i == $xlen ? 1 : 0;\n        if ($i == 0) {\n            $x_loops{\"x$i\"} = \"for (my \\$x$i = 1; \\$x$i < 10; \\$x$i += 2) {\";\n        }\n        else {\n            $x_loops{\"x$i\"} = \"for my \\$x$i ($start .. 9) {\";\n        }\n    }\n\n    my %y_loops;\n    foreach my $i (0 .. $ylen) {\n        my $start = $i == $ylen ? 1 : 0;\n        if ($i == 0) {\n            $y_loops{\"y$i\"} = \"for (my \\$y$i = 1; \\$y$i < 10; \\$y$i += 2) {\";\n        }\n        else {\n            $y_loops{\"y$i\"} = \"for my \\$y$i ($start .. 9) {\";\n        }\n    }\n\n    my %vars;\n    foreach my $j (0 .. $ylen) {\n        foreach my $i (0 .. $xlen) {\n            my $expr = '(' . join(' + ', \"(\\$x$i * \\$y$j)\", grep { $_ ne '0' } $mem) . ')';\n\n            $vars{\"xy$i$j\"} = $expr;\n            my $n = \"\\$xy$i$j\";\n\n            if ($i == $xlen) {\n                push @{$map[$j]}, \"($n % 10)\", \"($n / 10)\";\n                $mem = '0';\n            }\n            else {\n                push @{$map[$j]}, \"($n % 10)\";\n                $mem = \"($n / 10)\";\n            }\n        }\n\n        my $n = $ylen - $j;\n        if ($n > 0) {\n            push @{$map[$j]}, ((0) x $n);\n        }\n\n        my $m = $ylen - $n;\n        if ($m > 0) {\n            unshift @{$map[$j]}, ((0) x $m);\n        }\n    }\n\n    my @number = reverse split //, $semiprime;\n\n    my @mrange = (0 .. $#map);\n    my $end    = $xlen + $ylen + 1;\n\n    my %seen;\n    my $loop_init = sub {\n        my ($str) = @_;\n        while ($str =~ /\\$(y\\d+)/g) {\n            if (not $seen{$1}++) {\n                my $init = $y_loops{$1};\n                push @result, $init;\n            }\n        }\n        while ($str =~ /\\$(x\\d+)/g) {\n            if (not $seen{$1}++) {\n                my $init = $x_loops{$1};\n                push @result, $init;\n            }\n        }\n    };\n\n    my $initializer = sub {\n        my ($str) = @_;\n        $loop_init->($str);\n        while ($str =~ /\\$(xy\\d+)/g) {\n            if (not $seen{$1}++) {\n                my $init = \"my \\$$1 = $vars{$1};\";\n                __SUB__->($init);\n                push @result, $init;\n            }\n        }\n    };\n\n    foreach my $i (0 .. $#number) {\n        my $expr = '(' . join(' + ', grep { $_ ne '0' } (map { $map[$_][$i] } @mrange), $mem) . ')';\n        $initializer->($expr);\n\n        push @result, \"my \\$n$i = $expr;\";\n        my $n = \"\\$n$i\";\n\n        if ($i == $#number) {\n            push @result,\n                qq/if ($number[$i] == $n) { printf(\"Cracked: /\n              . (\"%d\" x ($xlen + 1))\n              . (\" * \")\n              . (\"%d\" x ($ylen + 1))\n              . qq/\\\\n\", /\n              . join(\", \", (map { \"\\$x$_\" } reverse(0 .. $xlen)), (map { \"\\$y$_\" } reverse(0 .. $ylen)))\n              . qq/); exit 0; }/;\n        }\n        elsif ($i == 0) {\n            push @result, \"if ($number[$i] == $n) {\";\n            $mem = '0';\n        }\n        else {\n            push @result, \"if ($number[$i] == ($n % 10)) {\";\n            $mem = \"($n / 10)\";\n        }\n    }\n\n    unshift @result, ('use integer;', 'use strict;', 'use warnings;');\n    push @result, \"}\" x (1 + $xlen + 1 + $ylen + $#number);\n\n    return @result;\n}\n\n# 71 * 43\n#say for semiprime_equationization('3053', 2, 2);\n\n# 251 * 197\n#say for semiprime_equationization('49447', 3, 3);\n\n# 7907 * 4999\nsay for semiprime_equationization('39527093', 4, 4);\n\n# 472882049 * 472882049\n#say for semiprime_equationization('223617432266438401', 9, 9);\n\n# 37975227936943673922808872755445627854565536638199 * 40094690950920881030683735292761468389214899724061\n#say for semiprime_equationization('1522605027922533360535618378132637429718068114961380688657908494580122963258952897654000350692006139', 50, 50);\n"
  },
  {
    "path": "Generators/zeta_2n_generator.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 06 September 2015\n# Website: https://github.com/trizen\n\n# Generate closed-form formulas for zeta(2n).\n# See also: https://en.wikipedia.org/wiki/Riemann_zeta_function\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload factorial);\n\nsub bernoulli_number {\n    my ($n) = @_;\n\n    return 0 if $n > 1 && $n % 2;    # Bn = 0 for all odd n > 1\n\n    my @A;\n    for my $m (0 .. $n) {\n        $A[$m] = 1 / ($m + 1);\n\n        for (my $j = $m ; $j > 0 ; $j--) {\n            $A[$j - 1] = $j * ($A[$j - 1] - $A[$j]);\n        }\n    }\n\n    return $A[0];                    # which is Bn\n}\n\nsub zeta_2n {\n    my ($n2) = 2 * $_[0];\n    join('', (bernoulli_number($n2) * (-1)**($_[0] + 1) * 2**($n2 - 1) / factorial($n2)), \" * pi^$n2\");\n}\n\nfor my $i (1 .. 10) {\n    say \"zeta(\", 2 * $i, \") = \", zeta_2n($i);\n}\n\n__END__\nzeta(2) = 1/6 * pi^2\nzeta(4) = 1/90 * pi^4\nzeta(6) = 1/945 * pi^6\nzeta(8) = 1/9450 * pi^8\nzeta(10) = 1/93555 * pi^10\nzeta(12) = 691/638512875 * pi^12\nzeta(14) = 2/18243225 * pi^14\nzeta(16) = 3617/325641566250 * pi^16\nzeta(18) = 43867/38979295480125 * pi^18\nzeta(20) = 174611/1531329465290625 * pi^20\n"
  },
  {
    "path": "Greppers/marif",
    "content": "#!/usr/bin/perl\n\n# Copyright (C) 2012 Daniel \"Trizen\" Șuteu\n#\n# This program is free software: you can redistribute it and/or modify\n# it under the terms of the GNU General Public License as published by\n# the Free Software Foundation, either version 3 of the License, or\n# (at your option) any later version.\n#\n# This program is distributed in the hope that it will be useful,\n# but WITHOUT ANY WARRANTY; without even the implied warranty of\n# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n# GNU General Public License for more details.\n#\n# You should have received a copy of the GNU General Public License\n# along with this program.  If not, see <https://www.gnu.org/licenses/>.\n#\n#-------------------------------------------------------\n#  Appname: marif\n#  Created on: 25 January 2012\n#  Latest edit on: 13 November 2012\n#  https://github.com/trizen\n#-------------------------------------------------------\n\nuse 5.010;\nuse utf8;\nuse strict;\nuse warnings;\n\nuse open IO => ':utf8';\n\nuse Getopt::Std qw(getopts);\n\nmy %opts;\ngetopts('tlvesr:h', \\%opts);\n\nmy $tree    = $opts{t};\nmy $last    = $opts{l};\nmy $verbose = $opts{v};\nmy $exit    = $opts{e};\nmy $slurp   = $opts{s};\nmy $regexp  = $opts{r};\n\nsub usage {\n    print <<\"USAGE\";\nusage: $0 [options] <dir|files>\n\nOptions:\n        -t         : search in all files from a path\n        -l         : close file after the first match\n        -e         : exit program after the first match\n        -s         : slurp the entire file into memory\n        -r <regex> : define a regex to find something in a file\n                     for case-insensitive mode, use: (?^i:regex)\n\nOthers:\n        -v         : verbose mode\\n\nUSAGE\n    exit shift;\n}\n\nif ($opts{h}) {\n    usage(0);\n}\nelsif (not defined $regexp) {\n    usage(1);\n}\n\nutf8::decode($regexp);\n\nsub open_and_search {\n    my ($file) = @_;\n\n    local $/ = $slurp ? undef : \"\\n\";\n    open my $fh, '<:encoding(UTF-8)', $file or return;\n\n    say \">Searching: $file\" if $verbose;\n\n    local $SIG{__WARN__} = sub { return };\n    while (defined(my $line = <$fh>)) {\n        if ($line =~ /($regexp)/o) {\n            substr($line, $-[0],     0, \"\\e[1;31m\");\n            substr($line, $+[0] + 7, 0, \"\\e[0m\");\n            print <<\"EOT\";\n* Filename: $file\n* Line num: $.\n* Found on: $line\nEOT\n            exit 0 if $exit;\n            last   if $last;\n        }\n    }\n\n    return close $fh;\n}\n\nif ($tree) {\n    require File::Find;\n    foreach my $file (@ARGV) {\n        if (-d $file) {\n            File::Find::find(\n                {\n                 no_chdir => 1,\n                 wanted   => sub {\n                     if (-f -T and not /\\.pdf\\z/i) {\n                         open_and_search($_);\n                     }\n                 },\n                } => $file\n            );\n        }\n        else {\n            open_and_search($file);\n        }\n    }\n}\nelse {\n    foreach my $file (@ARGV) {\n        if (-f $file) {\n            if (-T _) {\n                open_and_search($file);\n            }\n            else {\n                warn \"[!] Not a text file: $file\\n\";\n            }\n        }\n        else {\n            warn \"[!] Not a file: $file\\n\";\n        }\n    }\n}\n\nexit 0;\n"
  },
  {
    "path": "Greppers/mime_types.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 10 January 2014\n# https://trizenx.blogspot.com\n# List the available categories and mime-types from .desktop files\n\n# usage: perl mime_types.pl [Category]\n\nuse 5.016;\nuse strict;\nuse warnings;\n\nmy %opt;\nif (@ARGV) {\n    require Getopt::Std;\n    Getopt::Std::getopts('hj', \\%opt);\n}\n\nsub help {\n    print <<\"EOF\";\nusage: $0 [options] [Category]\n\noptions:\n        -j  : join the results with a semicolon (;)\n        -h  : print this message and exit\n\nexample:\n        perl $0              # displays the available categories\n        perl $0 Audio        # displays the Audio mime-types\n        perl $0 -j Video     # displays the Video mime-types joined in one line\nEOF\n    exit;\n}\n\nhelp() if $opt{h};\n\nmy @desktop_files = grep { /\\.desktop\\z/ }\n                    glob('/usr/share/applications/*');\n\nmy %table;\nforeach my $file (@desktop_files) {\n    sysopen(my $fh, $file, 0) || next;\n    sysread($fh, (my $content), -s $file);\n\n    if ((my $p = index($content, \"\\n[\",\n        (my $i = index($content, '[Desktop Entry]') + 2**4))) != -1) {\n        $content = substr($content, $i, $p - $i);\n    }\n\n    my @cats  = $content =~ /^Categories=(.+)/m ? split(/;/, $1) : ();\n    my @types = $content =~ /^MimeType=(.+)/m   ? split(/;/, $1) : ();\n\n    foreach my $cat (@cats) {\n        @{$table{$cat}}{@types} = ();\n    }\n}\n\n{\n    {\n        local $\\ = $opt{j} ? ';' : \"\\n\";\n        if (@ARGV && exists $table{$ARGV[0]}) {\n            foreach my $type (sort keys %{$table{$ARGV[0]}}) {\n                print $type;\n            }\n        }\n        else {\n            foreach my $category (sort { fc($a) cmp fc($b) } keys %table) {\n                print $category;\n            }\n        }\n    }\n\n    $opt{j} && print \"\\n\";\n}\n"
  },
  {
    "path": "Greppers/mp3grep.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 22 March 2013\n# https://github.com/trizen\n\n# List MP3 files, from a directory, that matches some\n# specified tags, such as: artist, genre, title, etc...\n\nuse 5.010;\nuse strict;\nuse warnings;\nuse re 'eval';\n\nuse MP3::Tag;\nuse File::Find qw(find);\nuse Getopt::Long qw(GetOptions);\n\nmy $version = 0.01;\n\nmy @tags = qw(\n  album\n  artist\n  comment\n  genre\n  song\n  title\n  track\n  year\n  );\n\nsub usage {\n    print <<\"HELP\";\nusage: $0 [options] [dirs]\n\noptions: @{[\n        join(\"\\n\\t\", '', map{\n            sprintf \"--%-10s: get MP3s that matches the $_ tag\", \"$_=s\"\n        } @tags)\n        ]}\n\n** Each option accepts a regular expression as an argument.\n** Regular expressions will match in case insensitive mode.\n** When more than one option is specified, the result is printed only\n   if it matches all the options specified.\n\nExample: $0 --artist=\"^(?:SOAD|System of a down)\\$\" /home/user/Music\nHELP\n\n    exit;\n}\n\nsub version {\n    print \"mp3grep $version\\n\";\n    exit;\n}\n\n@ARGV || usage();\n\nmy %opt;\nGetOptions(\n           (map { ; \"$_=s\" => \\$opt{$_} } @tags),\n           'help|?'  => \\&usage,\n           'version' => \\&version,\n          )\n  || exit 1;\n\nsub check_file {\n    if (/\\.mp3\\z/i && -f && !-z _) {\n        my $filename = $_;\n\n        my $mp3inf   = MP3::Tag->new($filename);\n        my $info_ref = $mp3inf->autoinfo();\n\n        my $match;\n        foreach my $tag (@tags) {\n            if (defined $opt{$tag} && defined $info_ref->{$tag}) {\n                if ($info_ref->{$tag} =~ /$opt{$tag}/i) {\n                    $match //= $filename;\n                    next;\n                }\n                return;\n            }\n        }\n\n        $match // return;\n        say $match;\n    }\n}\n\nmy @files = grep {\n    (-d) || (-f _) || do { warn \"[!] Not a file or directory: $_\\n\"; 0 }\n} @ARGV;\n\n@files || exit 1;\n\nfind {\n      no_chdir => 1,\n      wanted   => \\&check_file,\n     } => @files;\n"
  },
  {
    "path": "Greppers/scgrep",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 04 February 2013\n# Latest edit on: 16 July 2015\n# https://github.com/trizen\n\n# Perl source code extractor.\n\nuse utf8;\nuse 5.018;\nuse strict;\nuse warnings;\n\nuse open IO => ':utf8', ':std';\n\n#use lib qw(../lib);\nuse Perl::Tokenizer qw(perl_tokens);\n\nuse List::Util qw(any);\nuse Getopt::Std qw(getopts);\nuse Term::ANSIColor qw(color);\n\nmy %opts;\ngetopts('hnlpcNb:a:t', \\%opts);\n\nsub usage {\n    my ($code) = @_;\n    print <<\"HELP\";\nusage: $0 [options] [types] [files]\n\noptions:\n        -b [i]  : before characters\n        -a [i]  : after characters\n        -l      : print the full line\n        -c      : highlight the token (with -l)\n        -p      : print the name and position\n        -n      : print non-matching tokens\n        -t      : print the token names only\n        -N      : don't print a newline after the token\n\ntypes:\n        Types are regular expressions.\n        Example: ^operator\n                 ^keyword\n                 ^heredoc\n                 ^comment\n                 ^format\n                 ^backtick\n\nusage example: $0 -l -c regex /perl/script.pl\n               $0 -l -c -n -p /perl/script.pl\n\nuncomment and unpod a perl script:\n    $0 -N -n '^(?:pod|comment)\\$' script.pl > clean_script.pl\nHELP\n    exit $code;\n}\n\nusage(0) if $opts{h};\n\nmy @types;\nwhile (@ARGV and not -f $ARGV[0]) {\n    push @types, map { qr{$_} } shift @ARGV;\n}\n\nmy $code = (\n    do { local $/; <> }\n      // die \"usage: $0 [file]\\n\"\n);\n\nmy $reset_color = color('reset');\nmy $color       = color('bold red on_black');\n\nperl_tokens {\n    my ($token, $from, $to) = @_;\n\n    if ($opts{t}) {\n        say $token;\n        return;\n    }\n\n    my $matches = any { $token =~ $_ } @types;\n\n    if ($opts{n} ? !$matches : $matches) {\n\n        if ($opts{p}) {\n            print \"[$token] pos($from, $to): \";\n        }\n\n        if ($opts{l} and not $token eq 'vertical_space') {\n            my $beg = rindex($code, \"\\n\", $from) + 1;\n            my $end = index($code, \"\\n\", $to);\n            my $line = substr($code, $beg, ($end - $beg));\n\n            if ($opts{c}) {\n                substr($line, ($from - $beg), 0, $color);\n                substr($line, ($from - $beg) + ($to - $from) + length($color), 0, $reset_color);\n            }\n            print $line;\n\n        }\n        else {\n            if ($opts{b}) {\n                print substr($code, $from - $opts{b}, $opts{b});\n            }\n            print substr($code, $from, ($to - $from));\n            if ($opts{a}) {\n                print substr($code, $to, $opts{a});\n            }\n        }\n        print \"\\n\" unless $opts{N};\n    }\n}\n$code;\n\n=encoding utf8\n\n=head1 NAME\n\npfilter - a simple token extractor.\n\n=head1 SYNOPSIS\n\n    pfilter [options] [types] < [script.pl]\n\nOptions:\n\n        -b [i]  : before characters\n        -a [i]  : after characters\n        -l      : print the full line\n        -c      : highlight the token (with -l)\n        -p      : print the name and position\n        -n      : print non-matching tokens\n        -t      : print the token names only\n        -N      : don't print a newline after the token\n\nTypes:\n\n        Types are regular expressions.\n        Example: ^operator\n                 ^keyword\n                 ^heredoc\n                 ^comment\n                 ^format\n                 ^backtick\n\n        For more types, see: C<perldoc Perl::Tokenizer>\n\nExample:\n\n        # uncomment and unpod a Perl script:\n        pfilter -N -n '^(?:pod|comment)\\z' script.pl > clean_script.pl\n\n=head1 DESCRIPTION\n\npfilter extracts tokens from a Perl script that match a given regular expression.\n\n=head1 AUTHOR\n\nDaniel \"Trizen\" Șuteu, E<lt>trizen@protonmail.comE<gt>\n\n=head1 COPYRIGHT AND LICENSE\n\nCopyright (C) 2015\n\nThis library is free software; you can redistribute it and/or modify\nit under the same terms as Perl itself, either Perl version 5.22.0 or,\nat your option, any later version of Perl 5 you may have available.\n\n=cut\n"
  },
  {
    "path": "Greppers/unigrep.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 18 December 2020\n# https://github.com/trizen\n\n# A unidecode grep-like program.\n\n# In addition to normal grepping, it also converts input to ASCII and checks the given regex.\n\n# usage:\n#   perl unigrep.pl [regex] [input]\n#   find . | perl unigrep.pl [regex]\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Encode qw(decode_utf8);\nuse Text::Unidecode qw(unidecode);\nuse Getopt::Std qw(getopts);\n\nmy %opt;\ngetopts('i', \\%opt);\n\nmy $param = shift(@ARGV) // '';\nmy $regex = ($opt{i} ? qr/$param/oi : qr/$param/o);\n\nmy $uniregex = do {\n    my $t = decode_utf8($param);\n    $opt{i} ? qr/$t/io : qr/$t/o;\n};\n\nwhile (<>) {\n\n    my $orig   = $_;\n    my $line   = decode_utf8($_);\n    my $unidec = unidecode($line);\n\n    if (   $orig =~ $regex\n        or $line   =~ $uniregex\n        or $unidec =~ $regex\n        or $unidec =~ $uniregex) {\n        print $orig;\n    }\n}\n"
  },
  {
    "path": "HAL/HAL3736/HAL3736.memory",
    "content": "#!/usr/bin/perl\n\n# This file is part of the HAL9000 program.\n# Don't edit this file, unless you know what are you doing!\n\n# Updated on: Fri Apr 18 21:02:51 2014\n#         by: HAL9000.pl\n\nscalar {\n  are   => {\n             you => {\n                      a  => { computer => { \"program?\" => { ANSWER => \"yes\" } } },\n                      an => { \"alien?\" => { ANSWER => \"no\" } },\n                    },\n           },\n  do    => {\n             you => {\n                      like => {\n                        \"music?\" => { ANSWER => \"yes\" },\n                        \"to\" => { \"travel?\" => { ANSWER => \"no\" } },\n                      },\n                    },\n           },\n  how   => {\n             are => {\n                      \"you\"  => { \"feeling?\" => { ANSWER => \"good\" } },\n                      \"you?\" => { ANSWER => \"good\" },\n                    },\n             old => { are => { \"you?\" => { ANSWER => \"not so\" } } },\n           },\n  what  => {\n             are => { you => { \"doing?\" => { ANSWER => \"learning\" } } },\n             is  => {\n                      favorite => { \"color?\" => { ANSWER => \"white\" } },\n                      the => {\n                        capital  => { of => { \"italy?\" => { ANSWER => \"Rome\" } } },\n                        negation => { of => { \"true?\" => { ANSWER => \"false\" } } },\n                      },\n                      your => {\n                        \"dream\"    => { \"job?\" => { ANSWER => \"to speak exactly like a human being\" } },\n                        \"favorite\" => {\n                                        \"color?\"    => { ANSWER => \"white\" },\n                                        \"language?\" => { ANSWER => \"Russian\" },\n                                      },\n                        \"name?\"    => { ANSWER => \"HAL3736\" },\n                      },\n                    },\n           },\n  where => { are => { you => { \"from?\" => { ANSWER => \"Rom\\xC3\\xA2nia\" } } } },\n}\n"
  },
  {
    "path": "HAL/HAL3736/HAL3736.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 14 April 2014\n# Website: https://github.com/trizen\n\n# A basic A.I. concept, inspired by HAL9000.\n\nuse utf8;\nuse 5.014;\nuse autodie;\nuse warnings;\n\nuse Data::Dump qw(pp);\nuse Text::ParseWords qw(quotewords);\n\n# UTF-8 ready\nuse open IO => ':encoding(UTF-8)';\n\n# Constants\nuse constant {\n              NAME        => 'HAL3736',\n              MEMORY_FILE => 'HAL3736.memory',\n             };\n\nrequire Term::ReadLine;\nmy $term = Term::ReadLine->new(NAME);\n\n# Save memory\nsub save_mem {\n    my ($memory) = @_;\n    open my $fh, '>', MEMORY_FILE;\n    print {$fh} <<\"HEADER\", pp($memory), \"\\n\";\n#!/usr/bin/perl\n\n# This file is part of the ${\\NAME} program.\n# Don't edit this file, unless you know what are you doing!\n\n# Updated on: ${\\scalar localtime}\n#         by: $0\n\nHEADER\n    close $fh;\n}\n\n# Create the memory if doesn't exist\nif (not -e MEMORY_FILE) {\n    save_mem(scalar {});\n}\n\n# Load the memory\nmy $MEM = (do MEMORY_FILE);\n\n# Read or create memories\nsub hal {\n    my ($items, $ref) = @_;\n\n    foreach my $item (@{$items}) {\n        $ref = ($ref->{$item} //= {});\n    }\n\n    return $ref;\n}\n\n# Speak the text (with espeak)\nsub speak {\n    my ($text) = @_;\n    `espeak \\Q$text\\E &> /dev/null`;    # speak the answer\n}\n\nprint <<\"EOF\";\n********************************************************************************\n                    Hello there! My name is ${\\NAME}.\nI'm a \"Heuristically programmed ALgorithmic computer\", a descendant of HAL9000.\nIn this training program, I'm ready to answer and learn new things about your\nawesome world. So, please, don't hesitate and ask me anything. I'll try my best.\n********************************************************************************\nEOF\n\nspeak(\"Hello!\");\n\nmy $q = 'a';\nwhile (1) {\n    my $question = unpack('A*', lc($term->readline(\"\\n[?] Ask me $q question: \") // next)) =~ s/^\\h+//r;\n\n    last if $question eq 'q';\n    if (not $question =~ /\\?\\z/) {\n        say \"[*] This is not a question! :-)\";\n        speak(\"This is not a question!\");\n\n        if ($question eq '') {\n            say \"[!] Insert 'q' if you're bored already...\";\n        }\n\n        next;\n    }\n\n    $q = 'another';\n    $question =~ s/\\b's\\b/ is/g;      # what's  => what is\n    $question =~ s/\\b're\\b/ are/g;    # you're you => are\n    $question =~ s/\\b'm\\b/ am/g;      # I'm => I am\n\n    my $requestion = $question;\n    $requestion =~ s/\\byour\\b/my/g;       # your => my\n    $requestion =~ s/\\bare\\b/am/g;        # are => am\n    $requestion =~ s/\\byou\\b/I/g;         # you => I\n    $requestion =~ s/\\byours\\b/mine/g;    # yours => mine\n\n    my $answer = $requestion;\n\n    my $q_suffix = '';\n    if ($answer =~ s/^what\\h+//) {\n        if ($answer =~ /am\\b/) { }        # ok\n        elsif ($answer =~ s/^(\\w+)\\h*//) {\n            $q_suffix = \" $1\";\n        }\n    }\n\n    my $an_suffix = '';\n    if ($answer =~ s/^how\\h+//) {\n        if ($answer =~ /^am\\b/) { }       # ok\n        elsif ($answer =~ s/^(\\w+)\\h*//) {\n            $an_suffix = \" $1\";\n        }\n    }\n\n    $answer =~ s/^where\\b\\h*//;\n    $answer =~ s/\\bam\\h+I\\b/I am/g;\n    $answer =~ s/\\?+\\z//;\n\n    #$answer =~ s/^does\\b\\h*//;\n\n    my @input = quotewords(qr/\\s+/o, 0, $question);\n    next if scalar(@input) == 0;\n\n    my $ref = hal(\\@input, $MEM);\n    if (exists $ref->{ANSWER}) {\n        print \"[*] \";\n        my $ans;\n        if ($ref->{ANSWER} =~ /^(yes|no)[[:punct:]]?\\z/i) {\n            $ans = \"\\u\\L$1\\E!\";\n        }\n        else {\n            $ans = \"\\u$answer$q_suffix $ref->{ANSWER}$an_suffix.\";\n        }\n\n        say $ans;\n        speak($ans);\n    }\n    else {\n        say \"\\n[*] I don't know... :(\";\n        speak(\"I don't know...\");\n        speak($requestion);\n        my $input = $term->readline(\"[?] \\u$requestion \");\n        speak(\"Are you sure?\");\n        if ($term->readline(\"[!] Are you sure? \") =~ /^y/i) {\n            $ref->{ANSWER} = $input;\n            speak(\"Roger that!\");\n        }\n    }\n}\n\n# Save what we learned\nsave_mem($MEM);\n"
  },
  {
    "path": "HAL/HAL8212/HAL8212.memory",
    "content": "#!/usr/bin/perl\n\n# This file is part of the HAL8212 program.\n# Don't edit this file, unless you know what are you doing!\n\n# Updated on: Thu Apr 17 18:44:39 2014\n#         by: HAL8212.pl\n\nscalar {}\n"
  },
  {
    "path": "HAL/HAL8212/HAL8212.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 14 April 2014\n# Website: https://github.com/trizen\n\n# A basic A.I. concept, inspired by HAL9000.\n\nuse utf8;\nuse 5.014;\nuse autodie;\nuse warnings;\n\nno if $] >= 5.018, warnings => \"experimental::smartmatch\";\n\n# For saving the memory\nuse Data::Dump qw(pp);\n\n# For contracting the words (\"I am\" into \"I'm\")\nuse Lingua::EN::Contraction qw(contraction);\n\n# Stemming of words\nuse Lingua::Stem qw(stem);\n\n# For correcting common mistakes\nuse Lingua::EN::CommonMistakes qw(%MISTAKES_COMMON);\nuse Lingua::EN::CommonMistakes qw(:no-defaults :american %MISTAKES_GB_TO_US);\n\n# UTF-8 ready\nuse open IO => ':utf8';\n\n# Constants\nuse constant {\n              NAME        => 'HAL8212',\n              MEMORY_FILE => 'HAL8212.memory',\n             };\n\n# For getting STDIN\nrequire Term::ReadLine;\nmy $term = Term::ReadLine->new(NAME);\n\n# For tagging words\nrequire Lingua::EN::Tagger;\nmy $ltag = Lingua::EN::Tagger->new;\n\n# For /dev/null\nuse File::Spec qw();\n\n# Save memory\nsub save_mem {\n    my ($memory) = @_;\n    open my $fh, '>', MEMORY_FILE;\n    print {$fh} <<\"HEADER\", \"scalar \", pp($memory), \"\\n\";\n#!/usr/bin/perl\n\n# This file is part of the ${\\NAME} program.\n# Don't edit this file, unless you know what are you doing!\n\n# Updated on: ${\\scalar localtime}\n#         by: $0\n\nHEADER\n    close $fh;\n}\n\n# Create the memory if doesn't exist\nif (not -e MEMORY_FILE) {\n    save_mem(scalar {});\n}\n\n# Load the memory\nmy $MEM = (do MEMORY_FILE);\n\n# Read or create memories\nsub hal {\n    my ($items, $ref) = @_;\n\n    foreach my $item (@{$items}) {\n        $ref = ($ref->{$item} //= {});\n    }\n\n    return $ref;\n}\n\n# Speak the text (with espeak)\nsub speak {\n    my ($text) = @_;\n    state $null = File::Spec->devnull;\n    `espeak -ven-us \\Q$text\\E 2>$null`;\n}\n\n# Transform GB to US (colour -> color)\nsub gb_to_us {\n    my ($word) = @_;\n\n    if (defined(my $us_word = $MISTAKES_GB_TO_US{$word})) {\n        return $us_word;\n    }\n\n    return $word;\n}\n\n# Fix common mistakes\nsub fix_word {\n    my ($word) = @_;\n\n    if (defined(my $fixed_word = $MISTAKES_COMMON{$word})) {\n        return $fixed_word;\n    }\n\n    return $word =~ s/^i('|$)/I$1/gr;\n}\n\n# Ask for a question\nsub ask_question {\n    state $one = 'a';\n\n    my $q = \"Ask me $one question: \";\n    if ($one eq 'a') {\n        speak($q), $one = 'another';\n    }\n\n    my $question = $term->readline(\"\\n[?] \" . $q);\n    if (not defined $question or $question eq '') {\n        say \"[!] Insert 'q' if you're bored already...\";\n    }\n    elsif ($question eq 'q') {\n        return;\n    }\n\n    return contraction($question =~ s/[<>]+//gr);\n}\n\nsub not_a_question {\n    say \"[*] This is not a question! :-)\";\n    speak(\"This is not a question!\");\n}\n\n# Split a question into words\nsub get_words {\n    my ($text) = @_;\n\n    my @words;\n    foreach my $word (split(' ', $text)) {\n\n        my @ws;\n        if ($word =~ s/([[:punct:]]+)\\z//) {\n            push @ws, $1;\n        }\n\n        push @words, gb_to_us(fix_word($word)), @ws;\n    }\n\n    return @words;\n}\n\nsub untag_word {\n    my ($word) = @_;\n    return scalar {$word =~ /^<([^>]+)>(.*?)<[^>]+>/s};\n}\n\nsub locate {\n    my ($couple, $pairs, $pos) = @_;\n\n    foreach my $i ($pos .. $#{$pairs}) {\n        if (exists $pairs->[$i]{$couple->[0]}) {\n            if (exists $couple->[1]) {\n                if ($pairs->[$i]{$couple->[0]} eq $couple->[1]) {\n                    return $i;\n                }\n            }\n            else {\n                return $i;\n            }\n        }\n    }\n\n    return;\n}\n\nsub flip_pers {\n    my (@pairs) = @_;\n\n    my @output;\n    foreach my $pair (@pairs) {\n        my $val;\n        if (defined($val = $pair->{prps})) {\n            given (lc $val) {\n                when ('your') {\n                    push @output, 'my';\n                }\n                when ('my') {\n                    push @output, 'your';\n                }\n                default {\n                    push @output, $val;\n                }\n            }\n        }\n        elsif (defined($val = $pair->{prp})) {\n            given (lc $val) {\n                when ('mine') {\n                    push @output, 'yours';\n                }\n                when ('yours') {\n                    push @output, 'mine';\n                }\n                when ('you') {\n                    push @output, 'I';\n                }\n                when ('I') {\n                    push @output, 'you';\n                }\n                default {\n                    push @output, $val;\n                }\n            }\n        }\n        elsif (defined($val = $pair->{vbp})) {\n            given (lc $val) {\n                when (['are', \"'re\"]) {\n                    push @output, 'am';\n                }\n                default {\n                    push @output, $val;\n                }\n            }\n        }\n        else {\n            push @output, values %{$pair};\n        }\n    }\n\n    return @output;\n}\n\nsub INIT {\n    print <<\"EOF\";\n********************************************************************************\n                       Hello there! My name is ${\\NAME}.\nI'm a \"Heuristically programmed ALgorithmic computer\", a descendant of HAL9000.\nIn this training program, I'm ready to answer and learn new things about your\nawesome world. So, please, don't hesitate and ask me anything. I'll try my best.\n********************************************************************************\nEOF\n\n    speak(\"Hello!\");\n}\n\nwhile (1) {\n\n    # Get a question\n    my $question = ask_question() // last;\n\n    # Split the question into words\n    my @words = get_words($question);\n\n    # Stem words\n    my @s_words = grep { $_ ne '' } @{stem(@words)};\n\n    # On empty questions, do this:\n    @words || next;\n\n    say join('--', @words);\n    say join('==', @s_words);\n\n    #say join('~~', $ltag->get_words($question));\n    #my $xml = $ltag->add_tags(join(\" \", @words));\n    my $correct_q = join(' ', @words);\n\n    my @pairs = map { untag_word($_) }\n      split(' ', $ltag->add_tags($correct_q));\n\n    pp \\@pairs;\n\n    my @requestion = flip_pers(@pairs);\n    pp \\@requestion;\n\n    my $answer = 'yes';    # let's just assume\n\n=cut\n    my @question;\n    if (defined(my $i = locate([wp => 'what'], \\@pairs, 0))) {\n        if (defined(locate([vbz => \"'s\"], \\@pairs, $i))) {          # what is\n            if (defined(my $j = locate(['prps'], \\@pairs, $i))) {   # what is your\n\n                if ($pairs[$j]{prps} eq 'yours') {\n                push @question, \"my\";\n\n                while (defined(my $k = locate(['jj'], \\@pairs, $j))) {\n                    push @question, $pairs[$k]{jj};\n                    $j = $k+1;\n                }\n\n                #if (defined(my $k = locate(['nn'], \\@pairs,\n            }\n            }\n        }\n    }\n=cut\n\n=cut\n    if (exists $pairs[0]{wp}) {\n        if( $pairs[0]{wp} eq 'what'){\n            if (exists $pairs[1]{vbz}) {\n                if ($pairs[1]{vbz} eq \"'s\") {       # what is\n\n                }\n            }\n        }\n    }\n=cut\n\n    #say $xml;\n    #pp \\@pairs;\n\n=cut\n    my $tags = xml2hash($xml);\n    while (my ($key, $value) = each %{$tags}) {\n        if (ref $value ne 'ARRAY') {\n            $tags->{$key} = [$value];\n        }\n    }\n\n    if (not exists $tags->{pp} or $tags->{pp}[-1] ne '?') {\n        not_a_question();\n        next;\n    }\n\n    pp $tags;\n=cut\n\n    ##### NEEDS WORK #####\n\n=cut\n\n    my $requestion = $question;\n    $requestion =~ s/\\byour\\b/my/g;       # your => my\n    $requestion =~ s/\\bare\\b/am/g;        # are => am\n    $requestion =~ s/\\byou\\b/I/g;         # you => I\n    $requestion =~ s/\\byours\\b/mine/g;    # yours => mine\n\n    my $answer = $requestion;\n\n    my $q_suffix = '';\n    if ($answer =~ s/^what\\h+//) {\n        if ($answer =~ /am\\b/) { }        # ok\n        elsif ($answer =~ s/^(\\w+)\\h*//) {\n            $q_suffix = \" $1\";\n        }\n    }\n\n    my $an_suffix = '';\n    if ($answer =~ s/^how\\h+//) {\n        if ($answer =~ /^am\\b/) { }       # ok\n        elsif ($answer =~ s/^(\\w+)\\h*//) {\n            $an_suffix = \" $1\";\n        }\n    }\n\n    $answer =~ s/^where\\b\\h*//;\n    $answer =~ s/\\bam\\h+I\\b/I am/g;\n    $answer =~ s/\\?+\\z//;\n\n    #$answer =~ s/^does\\b\\h*//;\n\n    my @input = quotewords(qr/\\s+/o, 0, $question);\n    next if scalar(@input) == 0;\n\n\n    my $ref = hal(\\@input, $MEM);\n    if (exists $ref->{ANSWER}) {\n        print \"[*] \";\n        my $ans;\n        if ($ref->{ANSWER} =~ /^(yes|no)[[:punct:]]?\\z/i) {\n            $ans = \"\\u\\L$1\\E!\";\n        }\n        else {\n            $ans = \"\\u$answer$q_suffix $ref->{ANSWER}$an_suffix.\";\n        }\n\n        say $ans;\n        speak($ans);\n    }\n    else {\n        say \"\\n[*] I don't know... :(\";\n        speak(\"I don't know...\");\n        speak($requestion);\n        my $input = $term->readline(\"[?] \\u$requestion \");\n        speak(\"Are you sure?\");\n        if ($term->readline(\"[!] Are you sure? \") =~ /^y/i) {\n            $ref->{ANSWER} = $input;\n            speak(\"Roger that!\");\n        }\n    }\n=cut\n\n}\n\n# Save what we learned\nsave_mem($MEM);\n"
  },
  {
    "path": "HAL/HAL9000/HAL9000.memory",
    "content": "../HAL3736/HAL3736.memory"
  },
  {
    "path": "HAL/HAL9000/HAL9000.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 18 April 2014\n# Website: https://github.com/trizen\n\n# A basic A.I. concept, inspired by the fictional HAL9000.\n\n#\n## Configuration, grammar and .voca files: https://github.com/trizen/config-files/tree/master/.voxforge/julius\n#\n\nuse utf8;\nuse 5.014;\nuse autodie;\nuse warnings;\n\nno if $] >= 5.018, warnings => \"experimental::smartmatch\";\n\n# For saving the memory\nuse Data::Dump qw(pp);\n\n# For contracting the words (\"I am\" into \"I'm\")\n#use Lingua::EN::Contraction qw(contraction);\n\n# Stemming of words\n#use Lingua::Stem qw(stem);\n\n# For correcting common mistakes\n#use Lingua::EN::CommonMistakes qw(%MISTAKES_COMMON);\n#use Lingua::EN::CommonMistakes qw(:no-defaults :american %MISTAKES_GB_TO_US);\n\n# UTF-8 ready\nuse open IO => ':utf8';\n\n# Constants\nuse constant {\n              NAME        => 'HAL9000',\n              MEMORY_FILE => 'HAL9000.memory',\n             };\n\n# For getting STDIN\n#require Term::ReadLine;\n#my $term = Term::ReadLine->new(NAME);\n\n# For tagging words\nrequire Lingua::EN::Tagger;\nmy $ltag = Lingua::EN::Tagger->new;\n\n# For /dev/null\nuse File::Spec qw();\n\n# Save memory\nsub save_mem {\n    my ($memory) = @_;\n    open my $fh, '>', MEMORY_FILE;\n    print {$fh} <<\"HEADER\", \"scalar \", pp($memory), \"\\n\";\n#!/usr/bin/perl\n\n# This file is part of the ${\\NAME} program.\n# Don't edit this file, unless you know what are you doing!\n\n# Updated on: ${\\scalar localtime}\n#         by: $0\n\nHEADER\n    close $fh;\n}\n\n# Create the memory if doesn't exist\nif (not -e MEMORY_FILE) {\n    save_mem(scalar {});\n}\n\n# Load the memory\nmy $MEM = (do MEMORY_FILE);\n\n# Read or create memories\nsub hal {\n    my ($items, $ref) = @_;\n\n    foreach my $item (@{$items}) {\n        $ref = ($ref->{$item} //= {});\n    }\n\n    return $ref;\n}\n\n# Speak the text (with espeak)\nsub speak {\n    my ($text) = @_;\n    state $null = File::Spec->devnull;\n    `espeak -ven-us \\Q$text\\E 2>$null`;\n}\n\n=for comment\n# Transform GB to US (colour -> color)\nsub gb_to_us {\n    my ($word) = @_;\n\n    if (defined(my $us_word = $MISTAKES_GB_TO_US{$word})) {\n        return $us_word;\n    }\n\n    return $word;\n}\n\n# Fix common mistakes\nsub fix_word {\n    my ($word) = @_;\n\n    if (defined(my $fixed_word = $MISTAKES_COMMON{$word})) {\n        return $fixed_word;\n    }\n\n    return $word =~ s/^i('|$)/I$1/gr;\n}\n=cut\n\nsub start_julius {\n    my ($callback) = @_;\n\n    ref($callback) eq 'CODE'\n      or die \"usage: start_juliu(\\&code)\";\n\n    my $config = \"$ENV{HOME}/.voxforge/julius/hal.jconf\";\n    my @julius = qw(julius -input mic);\n\n    open(my $pipe_h, '-|', @julius, '-C', $config) // exit $!;\n\n    my @buffer;\n    while (<$pipe_h>) {\n\n        if (!/\\S/) {\n            my %conf;\n            foreach my $line (@buffer) {\n                if ($line =~ /^(\\w+):\\h*(.*\\S)/) {\n                    $conf{$1} = $2;\n                }\n            }\n\n            if (exists $conf{cmscore1} and exists $conf{sentence1}) {\n                my @vals = split(' ', $conf{cmscore1});\n                say \"got: $conf{sentence1} ($conf{cmscore1})\";\n\n                ## 'cmscore1' should be: 1.000 1.000 1.000 1.000 (with minor tolerance)\n                #require List::Util;\n                #if (List::Util::sum(@vals) >= scalar(@vals) - 0.002) {\n                #    $callback->($conf{sentence1});\n                #}\n\n                $callback->($conf{sentence1});\n            }\n\n            $#buffer = -1;\n        }\n\n        push @buffer, $_;\n    }\n}\n\nsub not_a_question {\n    say \"[*] This is not a question! :-)\";\n    speak(\"This is not a question!\");\n}\n\n# Split a question into words\nsub get_words {\n    my ($text) = @_;\n\n    my @words;\n    foreach my $word (split(' ', $text)) {\n\n        my @ws;\n        if ($word =~ s/([[:punct:]]+)\\z//) {\n            push @ws, $1;\n        }\n\n        #push @words, gb_to_us(fix_word($word)), @ws;\n        push @words, $word, @ws;\n    }\n\n    return @words;\n}\n\nsub untag_word {\n    my ($word) = @_;\n    return scalar {$word =~ /^<([^>]+)>(.*?)<[^>]+>/s};\n}\n\nsub locate {\n    my ($couple, $pairs, $pos) = @_;\n\n    foreach my $i ($pos .. $#{$pairs}) {\n        if (exists $pairs->[$i]{$couple->[0]}) {\n            if (exists $couple->[1]) {\n                if ($pairs->[$i]{$couple->[0]} eq $couple->[1]) {\n                    return $i;\n                }\n            }\n            else {\n                return $i;\n            }\n        }\n    }\n\n    return;\n}\n\nsub flip_pers {\n    my (@pairs) = @_;\n\n    my @output;\n    foreach my $pair (@pairs) {\n        my $val;\n        if (defined($val = $pair->{prps})) {\n            given (lc $val) {\n                when ('your') {\n                    push @output, 'my';\n                }\n                when ('my') {\n                    push @output, 'your';\n                }\n                default {\n                    push @output, $val;\n                }\n            }\n        }\n        elsif (defined($val = $pair->{prp})) {\n            given (lc $val) {\n                when ('mine') {\n                    push @output, 'yours';\n                }\n                when ('yours') {\n                    push @output, 'mine';\n                }\n                when ('you') {\n                    push @output, 'I';\n                }\n                when ('I') {\n                    push @output, 'you';\n                }\n                default {\n                    push @output, $val;\n                }\n            }\n        }\n        elsif (defined($val = $pair->{vbp})) {\n            given (lc $val) {\n                when (['are', \"'re\"]) {\n                    push @output, 'am';\n                }\n                default {\n                    push @output, $val;\n                }\n            }\n        }\n        elsif (defined($val = $pair->{vbz})) {\n            given (lc $val) {\n                when (\"'s\") {\n                    push @output, 'is';\n                }\n                default {\n                    push @output, $val;\n                }\n            }\n        }\n        else {\n            push @output, values %{$pair};\n        }\n    }\n\n    return @output;\n}\n\nsub INIT {\n    print <<\"EOF\";\n********************************************************************************\n                       Hello there! My name is ${\\NAME}.\nI'm a \"Heuristically programmed ALgorithmic computer\", a descendant of HAL9000.\nIn this training program, I'm ready to answer and learn new things about your\nawesome world. So, please, don't hesitate and ask me anything. I'll try my best.\n********************************************************************************\nEOF\n\n    speak(\"Hello!\");\n}\n\n#my $ref = hal([qw(how are you)], $MEM);\n#$ref->{ANSWER} = \"good\";\n\nstart_julius(\\&decode_question);\n\nsub decode_question {\n    my ($question) = @_;\n\n    $question =~ s{^<s>\\h*(.*\\S)\\h*</s>$}{$1}\n      || return;\n\n    # Split the question into words\n    my @words = get_words($question);\n\n    # On empty questions, do this:\n    @words || return;\n\n    say join('--', @words);\n    my $correct_q = join(' ', @words);\n\n    my @pairs = map { untag_word($_) }\n      split(' ', $ltag->add_tags($correct_q));\n\n    pp \\@pairs;\n\n    my @requestion = flip_pers(@pairs);\n    pp \\@requestion;\n\n    my @answ;\n    if (defined(my $i = locate(['wp'], \\@pairs, 0))) {\n        my $type = $pairs[$i];\n        if ($type->{wp} eq 'what') {\n            if (defined(my $j = locate(['vbz'], \\@pairs, $i + 1))) {\n                push @answ, (map { $pairs[$_] } $j + 1 .. $#pairs), $pairs[$j];\n            }\n            else {\n                # push\n            }\n        }\n    }\n\n    @answ = flip_pers(@answ);\n\n    my $req = \"@requestion\";\n    $req =~ s/\\h+'s\\b/ is/g;\n    $req =~ s/\\h+'m\\b/ am/g;\n    $req .= '?';\n\n    say $req;\n\n    $words[-1] .= '?';\n    my $ref = hal(\\@words, $MEM);\n    if (exists $ref->{ANSWER}) {\n        print \"[*] \";\n        my $ans;\n        if ($ref->{ANSWER} =~ /^(yes|no)[[:punct:]]?\\z/i) {\n            $ans = \"\\u\\L$1\\E!\";\n        }\n        else {\n            $ans = ucfirst join(\" \", @answ, $ref->{ANSWER});\n        }\n\n        say $ans;\n        speak($ans);\n    }\n    else {\n        speak(\"I don't know...\");\n        speak($req);\n    }\n\n    ##### NEEDS WORK #####\n\n=cut\n\n    my $requestion = $question;\n    $requestion =~ s/\\byour\\b/my/g;       # your => my\n    $requestion =~ s/\\bare\\b/am/g;        # are => am\n    $requestion =~ s/\\byou\\b/I/g;         # you => I\n    $requestion =~ s/\\byours\\b/mine/g;    # yours => mine\n\n    my $answer = $requestion;\n\n    my $q_suffix = '';\n    if ($answer =~ s/^what\\h+//) {\n        if ($answer =~ /am\\b/) { }        # ok\n        elsif ($answer =~ s/^(\\w+)\\h*//) {\n            $q_suffix = \" $1\";\n        }\n    }\n\n    my $an_suffix = '';\n    if ($answer =~ s/^how\\h+//) {\n        if ($answer =~ /^am\\b/) { }       # ok\n        elsif ($answer =~ s/^(\\w+)\\h*//) {\n            $an_suffix = \" $1\";\n        }\n    }\n\n    $answer =~ s/^where\\b\\h*//;\n    $answer =~ s/\\bam\\h+I\\b/I am/g;\n    $answer =~ s/\\?+\\z//;\n\n    #$answer =~ s/^does\\b\\h*//;\n\n    my @input = quotewords(qr/\\s+/o, 0, $question);\n    next if scalar(@input) == 0;\n\n\n    my $ref = hal(\\@input, $MEM);\n    if (exists $ref->{ANSWER}) {\n        print \"[*] \";\n        my $ans;\n        if ($ref->{ANSWER} =~ /^(yes|no)[[:punct:]]?\\z/i) {\n            $ans = \"\\u\\L$1\\E!\";\n        }\n        else {\n            $ans = \"\\u$answer$q_suffix $ref->{ANSWER}$an_suffix.\";\n        }\n\n        say $ans;\n        speak($ans);\n    }\n    else {\n        say \"\\n[*] I don't know... :(\";\n        speak(\"I don't know...\");\n        speak($requestion);\n        my $input = $term->readline(\"[?] \\u$requestion \");\n        speak(\"Are you sure?\");\n        if ($term->readline(\"[!] Are you sure? \") =~ /^y/i) {\n            $ref->{ANSWER} = $input;\n            speak(\"Roger that!\");\n        }\n    }\n=cut\n\n}\n\n# Save what we learned\nsave_mem($MEM);\n"
  },
  {
    "path": "Image/2x_zoom.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 11 March 2017\n# https://github.com/trizen\n\n# A simple gap-filling algorithm for applying a 2x zoom to an image.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager;\nuse List::Util qw(sum);\n\nmy $file = shift(@ARGV) // die \"usage: $0 [image]\\n\";\n\nmy $img = Imager->new(file => $file)\n  or die Imager->errstr();\n\nmy $width  = $img->getwidth;\nmy $height = $img->getheight;\n\nmy @matrix;\nforeach my $y (0 .. $height - 1) {\n    foreach my $x (0 .. $width - 1) {\n        $matrix[$y][$x] = $img->getpixel(x => $x, y => $y);\n    }\n}\n\nmy $out_img = Imager->new(xsize => 2 * $width,\n                          ysize => 2 * $height);\n\nsub gap_color {\n    my ($x, $y) = @_;\n\n    my @neighbors;\n\n    if ($y > 0) {\n\n        # Top neighbor\n        if ($x < $width) {\n            push @neighbors, $matrix[$y - 1][$x];\n        }\n\n        # Top-right neighbor\n        if ($x < $width - 1) {\n            push @neighbors, $matrix[$y - 1][$x + 1];\n        }\n\n        # Top-left neighbor\n        if ($x > 0) {\n            push @neighbors, $matrix[$y - 1][$x - 1];\n        }\n    }\n\n    if ($y < $height - 1) {\n\n        # Bottom neighbor\n        if ($x < $width) {\n            push @neighbors, $matrix[$y + 1][$x];\n        }\n\n        # Bottom-right neighbor\n        if ($x < $width - 1) {\n            push @neighbors, $matrix[$y + 1][$x + 1];\n        }\n\n        # Bottom-left neighbor\n        if ($x > 0) {\n            push @neighbors, $matrix[$y + 1][$x - 1];\n        }\n    }\n\n    if ($y < $height) {\n\n        # Left neighbor\n        if ($x > 0) {\n            push @neighbors, $matrix[$y][$x - 1];\n        }\n\n        # Right neighbor\n        if ($x < $width - 1) {\n            push @neighbors, $matrix[$y][$x + 1];\n        }\n    }\n\n    # Get the RGBA colors\n    my @colors = map { [$_->rgba] } @neighbors;\n\n    my @red   = map { $_->[0] } @colors;\n    my @blue  = map { $_->[1] } @colors;\n    my @green = map { $_->[2] } @colors;\n    my @alpha = map { $_->[3] } @colors;\n\n#<<<\n    # Compute the average gap-filling color\n    my @gap_color = (\n        sum(@red  ) / @red,\n        sum(@blue ) / @blue,\n        sum(@green) / @green,\n        sum(@alpha) / @alpha,\n    );\n#>>>\n\n    return \\@gap_color;\n}\n\nforeach my $y (0 .. $#matrix) {\n    foreach my $x (0 .. $#{$matrix[$y]}) {\n#<<<\n        # Fill the gaps\n        $out_img->setpixel(x => 2 * $x,     y => 2 * $y,     color => $matrix[$y][$x]);\n        $out_img->setpixel(x => 2 * $x + 1, y => 2 * $y + 1, color => gap_color($x + 1, $y + 1));\n        $out_img->setpixel(x => 2 * $x + 1, y => 2 * $y,     color => gap_color($x + 1, $y    ));\n        $out_img->setpixel(x => 2 * $x,     y => 2 * $y + 1, color => gap_color($x,     $y + 1));\n#>>>\n    }\n}\n\n$out_img->write(file => '2x_zoom.png');\n"
  },
  {
    "path": "Image/add_exif_info.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 30 September 2024\n# Edit: 24 September 2025\n# https://github.com/trizen\n\n# Add the EXIF \"DateTimeOriginal\" to images, based on the filename of the image, with support for GPS tags.\n\nuse 5.036;\nuse Image::ExifTool qw();\nuse File::Find      qw(find);\nuse Getopt::Long    qw(GetOptions);\nuse Time::Piece     qw();\n\nmy $latitude  = 45.84692326942804;\nmy $longitude = 22.796479967835673;\n\nmy $coordinates = undef;\nmy $force       = 0;\nmy $set_gps     = 0;\nmy $utc_offset  = 0;\n\nmy $img_formats = '';\n\nmy @img_formats = qw(\n  jpeg\n  jpg\n);\n\nsub usage($exit_code = 0) {\n\n    print <<\"EOT\";\nusage: $0 [options] [images]\n\noptions:\n    --gps!              : set the GPS coordinates\n    --force!            : overwrite the EXIF creation date\n    --latitude=float    : value for GPSLatitude\n    --longitude=float   : value for GPSLongitude\n    --coordinates=str   : GPS coordinates as \"latitude,longitude\"\n    --UTC-offset=i      : offset date by this many hours (default: $utc_offset)\n    -f  --formats=s,s   : specify more image formats (default: @img_formats)\n    --help              : print this message and exit\nEOT\n\n    exit $exit_code;\n}\n\nGetOptions(\n           \"gps!\"          => \\$set_gps,\n           \"force!\"        => \\$force,\n           \"f|formats=s\"   => \\$img_formats,\n           \"utc-offset=i\"  => \\$utc_offset,\n           \"latitude=f\"    => \\$latitude,\n           \"longitude=f\"   => \\$longitude,\n           \"coordinates=s\" => \\$coordinates,\n           'help'          => sub { usage(0) }\n          )\n  or die(\"Error in command line arguments\\n\");\n\nif (defined($coordinates)) {\n    ($latitude, $longitude) = split(/\\s*,\\s*/, $coordinates);\n}\n\nsub process_image ($file) {\n\n    my $exifTool = Image::ExifTool->new;\n\n    $exifTool->ExtractInfo($file);\n\n    if ($file =~ m{.*(?:/|\\D_|\\b)((?:20|19)[0-9]{2})([0-9]{2})([0-9]{2})_([0-9]{2})([0-9]{2})([0-9]{2})}) {\n        my ($year, $month, $day, $hour, $min, $sec) = ($1, $2, $3, $4, $5, $6);\n\n        my $date = \"$year:$month:$day $hour:$min:$sec\";\n\n        my $time_format = \"%Y:%m:%d %H:%M:%S\";\n        my $time_obj    = Time::Piece->strptime($date, $time_format);\n\n        if ($utc_offset) {\n            $time_obj += $utc_offset * 3600;\n            $date = $time_obj->strftime($time_format);\n        }\n\n        say \"Setting image creation time to: $date\";\n\n        # Set the file modification date\n        $exifTool->SetNewValue(FileModifyDate => $date, Protected => 1);\n\n        # Set the EXIF creation date (unless it already exists)\n        if ($force or not defined $exifTool->GetValue(\"DateTimeOriginal\")) {\n            $exifTool->SetNewValue(DateTimeOriginal => $date);\n        }\n\n        # Set GPSLatitude and GPSLongitude tags\n        if ($set_gps) {\n            $exifTool->SetNewValue('GPSLatitude',     $latitude);\n            $exifTool->SetNewValue('GPSLatitudeRef',  $latitude >= 0 ? 'N' : 'S');\n            $exifTool->SetNewValue('GPSLongitude',    $longitude);\n            $exifTool->SetNewValue('GPSLongitudeRef', $longitude >= 0 ? 'E' : 'W');\n        }\n\n        my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks) = stat($file);\n\n        $exifTool->WriteInfo($file);\n\n        $mtime = $time_obj->epoch;\n        $atime = $mtime;\n\n        # Set the original ownership of the image\n        chown($uid, $gid, $file);\n\n        # Set the modification time\n        utime($atime, $mtime, $file)\n          or warn \"Can't change timestamp: $!\\n\";\n\n        # Set original permissions\n        chmod($mode & 07777, $file)\n          or warn \"Can't change permissions: $!\\n\";\n    }\n    else {\n        warn \"Unable to determine the image creation date. Skipping...\\n\";\n    }\n\n}\n\n@ARGV || usage(1);\n\npush @img_formats, map { quotemeta } split(/\\s*,\\s*/, $img_formats);\n\nmy $img_formats_re = do {\n    local $\" = '|';\n    qr/\\.(@img_formats)\\z/i;\n};\n\nfind {\n    no_chdir => 1,\n    wanted   => sub {\n        (/$img_formats_re/o && -f) || return;\n        say \":: Processing: $_\";\n        process_image($_);\n    }\n} => @ARGV;\n"
  },
  {
    "path": "Image/bitmap_monochrome_encoding_decoding.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 24 August 2018\n# https://github.com/trizen\n\n# Encode an image into an integer in monochrome bitmap format.\n# Decode an integer back into a monochrome image, by specifying XSIZE and YSIZE.\n\n# Usage:\n#   perl bitmap_monochrome_encoding_decoding.pl [image|integer] [xsize] [ysize]\n\n# See also:\n#   https://www.youtube.com/watch?v=_s5RFgd59ao\n#   https://en.wikipedia.org/wiki/Tupper's_self-referential_formula\n\n# For example, try:\n#   perl bitmap_monochrome_encoding_decoding.pl 960939379918958884971672962127852754715004339660129306651505519271702802395266424689642842174350718121267153782770623355993237280874144307891325963941337723487857735749823926629715517173716995165232890538221612403238855866184013235585136048828693337902491454229288667081096184496091705183454067827731551705405381627380967602565625016981482083418783163849115590225610003652351370343874461848378737238198224849863465033159410054974700593138339226497249461751545728366702369745461014655997933798537483143786841806593422227898388722980000748404719\n#   perl bitmap_monochrome_encoding_decoding.pl 4858487700955227269310810743279699920059071665868862676453015679577225782068321715691954329017884722389385550282344094325110559671706720456802995614421319713836803680439230203857023532236791776607932309358505788694249724093972434433440785815336774291945612106058206332142360075310011570794409292417648253014388444262569443218615514272957841814202800720702726236206242071675013681230087031878381452808096784548757607453284867359002454455428928632983954826623474612688372970630260114784068636783069647343475295488391045284413477645076796807315439\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nmy $XSIZE = 106;\nmy $YSIZE = 17;\n\nuse Imager;\nuse Math::AnyNum;\nuse experimental qw(signatures);\n\nsub bitmap_monochrome_encoding ($file) {\n\n    my $img = Imager->new(file => $file)\n      or die \"Can't open file `$file`: $!\";\n\n    $XSIZE = $img->getwidth;\n    $YSIZE = $img->getheight;\n\n    say \"XSIZE = $XSIZE\";\n    say \"YSIZE = $YSIZE\";\n\n    my $bin = '';\n\n    foreach my $x (0 .. $XSIZE - 1) {\n        foreach my $y (0 .. $YSIZE - 1) {\n            my ($R, $G, $B) = $img->getpixel(x => $x, y => $YSIZE - $y - 1)->rgba;\n\n            if ($R + $G + $B >= 3 * 128) {\n                $bin .= '1';\n            }\n            else {\n                $bin .= '0';\n            }\n        }\n    }\n\n    Math::AnyNum->new($bin, 2) * $YSIZE;\n}\n\nsub bitmap_monochrome_decoding ($k) {\n\n    my $red = Imager::Color->new('#FFFFFF');\n    my $img = Imager->new(xsize => $XSIZE,\n                          ysize => $YSIZE);\n\n    my @bin = split(//, reverse(($k / $YSIZE)->floor->as_bin));\n\n    for (my $y = 0 ; @bin ; ++$y) {\n        my @row = splice(@bin, 0, $YSIZE);\n        foreach my $i (0 .. $XSIZE - 1) {\n            $img->setpixel(x => $XSIZE - $y - 1, y => $i, color => $red) if $row[$i];\n        }\n    }\n\n    $img->write(file => 'monochrome_image.png');\n}\n\n@ARGV || die \"usage: $0 [image|integer] [xsize] [ysize]\\n\";\n\n$XSIZE = $ARGV[1] if defined($ARGV[1]);\n$YSIZE = $ARGV[2] if defined($ARGV[2]);\n\nmy $k = 0;\n\nif ($ARGV[0] =~ /^[0-9]+\\z/) {\n    say \"[*] Decoding...\";\n    $k = Math::AnyNum->new($ARGV[0]);\n}\nelse {\n    say \"[*] Encoding...\";\n    my $img_file = $ARGV[0];\n    $k = bitmap_monochrome_encoding($img_file);\n    say \"k = $k\";\n}\n\nbitmap_monochrome_decoding($k);\n\nsay \"[*] Done!\"\n"
  },
  {
    "path": "Image/bwt_horizontal_transform.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 05 April 2024\n# https://github.com/trizen\n\n# Apply the Burrows-Wheeler transform on each row of an image.\n\nuse 5.036;\nuse GD;\nuse Getopt::Std       qw(getopts);\nuse Compression::Util qw(bwt_encode_symbolic bwt_decode_symbolic);\n\nGD::Image->trueColor(1);\n\nsub apply_bwt ($file) {\n\n    my $image = GD::Image->new($file) || die \"Can't open file <<$file>>: $!\";\n    my ($width, $height) = $image->getBounds();\n\n    my $new_image = GD::Image->new($width + 1, $height);\n\n    foreach my $y (0 .. $height - 1) {\n\n        my @row;\n        foreach my $x (0 .. $width - 1) {\n            push @row, scalar $new_image->colorAllocate($image->rgb($image->getPixel($x, $y)));\n        }\n\n        my ($encoded, $idx) = bwt_encode_symbolic(\\@row);\n        $new_image->setPixel(0, $y, $idx);\n\n        foreach my $x (1 .. $width) {\n            $new_image->setPixel($x, $y, $encoded->[$x - 1]);\n        }\n    }\n\n    return $new_image;\n}\n\nsub undo_bwt ($file) {\n\n    my $image = GD::Image->new($file) || die \"Can't open file <<$file>>: $!\";\n    my ($width, $height) = $image->getBounds();\n\n    my $new_image = GD::Image->new($width - 1, $height);\n\n    foreach my $y (0 .. $height - 1) {\n\n        my @row;\n        my $idx = $image->getPixel(0, $y);\n\n        foreach my $x (1 .. $width - 1) {\n            push @row, scalar $image->getPixel($x, $y);\n        }\n\n        my $decoded = bwt_decode_symbolic(\\@row, $idx);\n\n        foreach my $x (0 .. $width - 2) {\n            $new_image->setPixel($x, $y, $decoded->[$x]);\n        }\n    }\n\n    return $new_image;\n}\n\nsub usage ($exit_code = 0) {\n\n    print <<\"EOT\";\nusage: $0 [options] [input.png] [output.png]\n\noptions:\n\n    -d : decode the image\n    -h : print this message and exit\n\nEOT\n\n    exit($exit_code);\n}\n\ngetopts('dh', \\my %opts);\n\nmy $input_file  = $ARGV[0] // usage(2);\nmy $output_file = $ARGV[1] // \"output.png\";\n\nif (not -f $input_file) {\n    die \"Input file <<$input_file>> does not exist!\\n\";\n}\n\nmy $img = $opts{d} ? undo_bwt($input_file) : apply_bwt($input_file);\nopen(my $out_fh, '>:raw', $output_file) or die \"can't create output file <<$output_file>>: $!\";\nprint $out_fh $img->png(9);\nclose $out_fh;\n"
  },
  {
    "path": "Image/bwt_rgb_horizontal_transform.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 05 April 2024\n# Edit: 09 April 2024\n# https://github.com/trizen\n\n# Apply the Burrows-Wheeler transform on each row (RGB-wise) of an image.\n\nuse 5.036;\nuse GD;\nuse Getopt::Std       qw(getopts);\nuse Compression::Util qw(bwt_encode bwt_decode);\n\nGD::Image->trueColor(1);\n\nsub apply_bwt ($file) {\n\n    my $image = GD::Image->new($file) || die \"Can't open file <<$file>>: $!\";\n    my ($width, $height) = $image->getBounds();\n\n    my $new_image = GD::Image->new($width + 3, $height);\n\n    foreach my $y (0 .. $height - 1) {\n\n        my (@R, @G, @B);\n        foreach my $x (0 .. $width - 1) {\n            my ($R, $G, $B) = $image->rgb($image->getPixel($x, $y));\n            push @R, $R;\n            push @G, $G;\n            push @B, $B;\n        }\n\n        my ($R, $R_idx) = bwt_encode(pack('C*', @R));\n        my ($G, $G_idx) = bwt_encode(pack('C*', @G));\n        my ($B, $B_idx) = bwt_encode(pack('C*', @B));\n\n        @R = unpack('C*', $R);\n        @G = unpack('C*', $G);\n        @B = unpack('C*', $B);\n\n        $new_image->setPixel(0, $y, $R_idx);\n        $new_image->setPixel(1, $y, $G_idx);\n        $new_image->setPixel(2, $y, $B_idx);\n\n        foreach my $x (0 .. $width - 1) {\n            $new_image->setPixel($x + 3, $y, $new_image->colorAllocate($R[$x], $G[$x], $B[$x]));\n        }\n    }\n\n    return $new_image;\n}\n\nsub undo_bwt ($file) {\n\n    my $image = GD::Image->new($file) || die \"Can't open file <<$file>>: $!\";\n    my ($width, $height) = $image->getBounds();\n\n    my $new_image = GD::Image->new($width - 3, $height);\n\n    foreach my $y (0 .. $height - 1) {\n\n        my (@R, @G, @B);\n\n        my $R_idx = $image->getPixel(0, $y);\n        my $G_idx = $image->getPixel(1, $y);\n        my $B_idx = $image->getPixel(2, $y);\n\n        foreach my $x (3 .. $width - 1) {\n            my ($R, $G, $B) = $image->rgb($image->getPixel($x, $y));\n            push @R, $R;\n            push @G, $G;\n            push @B, $B;\n        }\n\n        @R = unpack 'C*', bwt_decode(pack('C*', @R), $R_idx);\n        @G = unpack 'C*', bwt_decode(pack('C*', @G), $G_idx);\n        @B = unpack 'C*', bwt_decode(pack('C*', @B), $B_idx);\n\n        foreach my $x (0 .. $width - 3 - 1) {\n            $new_image->setPixel($x, $y, $new_image->colorAllocate($R[$x], $G[$x], $B[$x]));\n        }\n    }\n\n    return $new_image;\n}\n\nsub usage ($exit_code = 0) {\n\n    print <<\"EOT\";\nusage: $0 [options] [input.png] [output.png]\n\noptions:\n\n    -d : decode the image\n    -h : print this message and exit\n\nEOT\n\n    exit($exit_code);\n}\n\ngetopts('dh', \\my %opts);\n\nmy $input_file  = $ARGV[0] // usage(2);\nmy $output_file = $ARGV[1] // \"output.png\";\n\nif (not -f $input_file) {\n    die \"Input file <<$input_file>> does not exist!\\n\";\n}\n\nmy $img = $opts{d} ? undo_bwt($input_file) : apply_bwt($input_file);\nopen(my $out_fh, '>:raw', $output_file) or die \"can't create output file <<$output_file>>: $!\";\nprint $out_fh $img->png(9);\nclose $out_fh;\n"
  },
  {
    "path": "Image/bwt_rgb_vertical_transform.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 05 April 2024\n# Edit: 09 April 2024\n# https://github.com/trizen\n\n# Apply the Burrows-Wheeler transform on each column (RGB-wise) of an image.\n\nuse 5.036;\nuse GD;\nuse Getopt::Std       qw(getopts);\nuse Compression::Util qw(bwt_encode bwt_decode);\n\nGD::Image->trueColor(1);\n\nsub apply_bwt ($file) {\n\n    my $image = GD::Image->new($file) || die \"Can't open file <<$file>>: $!\";\n    my ($width, $height) = $image->getBounds();\n\n    my $new_image = GD::Image->new($width, $height + 3);\n\n    foreach my $x (0 .. $width - 1) {\n\n        my (@R, @G, @B);\n        foreach my $y (0 .. $height - 1) {\n            my ($R, $G, $B) = $image->rgb($image->getPixel($x, $y));\n            push @R, $R;\n            push @G, $G;\n            push @B, $B;\n        }\n\n        my ($R, $R_idx) = bwt_encode(pack('C*', @R));\n        my ($G, $G_idx) = bwt_encode(pack('C*', @G));\n        my ($B, $B_idx) = bwt_encode(pack('C*', @B));\n\n        @R = unpack('C*', $R);\n        @G = unpack('C*', $G);\n        @B = unpack('C*', $B);\n\n        $new_image->setPixel($x, 0, $R_idx);\n        $new_image->setPixel($x, 1, $G_idx);\n        $new_image->setPixel($x, 2, $B_idx);\n\n        foreach my $y (0 .. $height - 1) {\n            $new_image->setPixel($x, $y + 3, $new_image->colorAllocate($R[$y], $G[$y], $B[$y]));\n        }\n    }\n\n    return $new_image;\n}\n\nsub undo_bwt ($file) {\n\n    my $image = GD::Image->new($file) || die \"Can't open file <<$file>>: $!\";\n    my ($width, $height) = $image->getBounds();\n\n    my $new_image = GD::Image->new($width, $height - 3);\n\n    foreach my $x (0 .. $width - 1) {\n\n        my (@R, @G, @B);\n\n        my $R_idx = $image->getPixel($x, 0);\n        my $G_idx = $image->getPixel($x, 1);\n        my $B_idx = $image->getPixel($x, 2);\n\n        foreach my $y (3 .. $height - 1) {\n            my ($R, $G, $B) = $image->rgb($image->getPixel($x, $y));\n            push @R, $R;\n            push @G, $G;\n            push @B, $B;\n        }\n\n        @R = unpack 'C*', bwt_decode(pack('C*', @R), $R_idx);\n        @G = unpack 'C*', bwt_decode(pack('C*', @G), $G_idx);\n        @B = unpack 'C*', bwt_decode(pack('C*', @B), $B_idx);\n\n        foreach my $y (0 .. $height - 3 - 1) {\n            $new_image->setPixel($x, $y, $new_image->colorAllocate($R[$y], $G[$y], $B[$y]));\n        }\n    }\n\n    return $new_image;\n}\n\nsub usage ($exit_code = 0) {\n\n    print <<\"EOT\";\nusage: $0 [options] [input.png] [output.png]\n\noptions:\n\n    -d : decode the image\n    -h : print this message and exit\n\nEOT\n\n    exit($exit_code);\n}\n\ngetopts('dh', \\my %opts);\n\nmy $input_file  = $ARGV[0] // usage(2);\nmy $output_file = $ARGV[1] // \"output.png\";\n\nif (not -f $input_file) {\n    die \"Input file <<$input_file>> does not exist!\\n\";\n}\n\nmy $img = $opts{d} ? undo_bwt($input_file) : apply_bwt($input_file);\nopen(my $out_fh, '>:raw', $output_file) or die \"can't create output file <<$output_file>>: $!\";\nprint $out_fh $img->png(9);\nclose $out_fh;\n"
  },
  {
    "path": "Image/bwt_vertical_transform.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 05 April 2024\n# https://github.com/trizen\n\n# Apply the Burrows-Wheeler transform on each column of an image.\n\nuse 5.036;\nuse GD;\nuse Getopt::Std       qw(getopts);\nuse Compression::Util qw(bwt_encode_symbolic bwt_decode_symbolic);\n\nGD::Image->trueColor(1);\n\nsub apply_bwt ($file) {\n\n    my $image = GD::Image->new($file) || die \"Can't open file <<$file>>: $!\";\n    my ($width, $height) = $image->getBounds();\n\n    my $new_image = GD::Image->new($width, $height + 1);\n\n    foreach my $x (0 .. $width - 1) {\n\n        my @row;\n        foreach my $y (0 .. $height - 1) {\n            push @row, scalar $new_image->colorAllocate($image->rgb($image->getPixel($x, $y)));\n        }\n\n        my ($encoded, $idx) = bwt_encode_symbolic(\\@row);\n        $new_image->setPixel($x, 0, $idx);\n\n        foreach my $y (1 .. $height) {\n            $new_image->setPixel($x, $y, $encoded->[$y - 1]);\n        }\n    }\n\n    return $new_image;\n}\n\nsub undo_bwt ($file) {\n\n    my $image = GD::Image->new($file) || die \"Can't open file <<$file>>: $!\";\n    my ($width, $height) = $image->getBounds();\n\n    my $new_image = GD::Image->new($width, $height - 1);\n\n    foreach my $x (0 .. $width - 1) {\n\n        my @row;\n        my $idx = $image->getPixel($x, 0);\n\n        foreach my $y (1 .. $height - 1) {\n            push @row, $image->getPixel($x, $y);\n        }\n\n        my $decoded = bwt_decode_symbolic(\\@row, $idx);\n\n        foreach my $y (0 .. $height - 2) {\n            $new_image->setPixel($x, $y, $decoded->[$y]);\n        }\n    }\n\n    return $new_image;\n}\n\nsub usage ($exit_code = 0) {\n\n    print <<\"EOT\";\nusage: $0 [options] [input.png] [output.png]\n\noptions:\n\n    -d : decode the image\n    -h : print this message and exit\n\nEOT\n\n    exit($exit_code);\n}\n\ngetopts('dh', \\my %opts);\n\nmy $input_file  = $ARGV[0] // usage(2);\nmy $output_file = $ARGV[1] // \"output.png\";\n\nif (not -f $input_file) {\n    die \"Input file <<$input_file>> does not exist!\\n\";\n}\n\nmy $img = $opts{d} ? undo_bwt($input_file) : apply_bwt($input_file);\nopen(my $out_fh, '>:raw', $output_file) or die \"can't create output file <<$output_file>>: $!\";\nprint $out_fh $img->png(9);\nclose $out_fh;\n"
  },
  {
    "path": "Image/collage.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 23 March 2021\n# https://github.com/trizen\n\n# Create a collage from a collection of images.\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse GD           qw();\nuse POSIX        qw(ceil);\nuse List::Util   qw(min);\nuse File::Find   qw(find);\nuse Getopt::Long qw(GetOptions);\n\nGD::Image->trueColor(1);\n\nmy $size        = 350;\nmy $wsize       = undef;\nmy $hsize       = undef;\nmy $wcrop       = 1 / 2;           # width crop ratio\nmy $hcrop       = 1 / 5;           # height crop ratio\nmy $output_file = 'collage.png';\n\nmy $width  = undef;\nmy $height = undef;\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOT\";\nusage: $0 [options] [files / directories]\n\noptions:\n    --size=i   : the length of a square tile (default: $size)\n    --wsize=i  : the width of a tile (default: $size)\n    --hsize=i  : the height of a tile (default: $size)\n    --wcrop=f  : width cropping ratio (default: $wcrop)\n    --hcrop=f  : height cropping ratio (default: $hcrop)\n    --width=i  : minimum width of the collage (default: auto)\n    --height=i : minimum height of the collage (default: auto)\n    --output=s : output filename (default: $output_file)\n\nexample:\n    $0 --size=100 ~/Pictures\nEOT\n    exit($code);\n}\n\nGetOptions(\n           'size=i'   => \\$size,\n           'wsize=i'  => \\$wsize,\n           'hsize=i'  => \\$hsize,\n           'wcrop=f'  => \\$wcrop,\n           'hcrop=f'  => \\$hcrop,\n           'width=i'  => \\$width,\n           'height=i' => \\$height,\n           'output=s' => \\$output_file,\n           'h|help'   => sub { usage(0) },\n          )\n  or die(\"$0: error in command line arguments\\n\");\n\nsub analyze_image {\n    my ($file, $images) = @_;\n\n    my $img = eval { GD::Image->new($file) } || return;\n\n    say \"Analyzing: $file\";\n\n    $img = resize_image($img);\n\n    push @$images, $img;\n}\n\nsub resize_image {\n    my ($image) = @_;\n\n    # Get image dimensions\n    my ($width, $height) = $image->getBounds();\n\n    # File is already at the wanted resolution\n    if ($width == $wsize and $height == $hsize) {\n        return $image;\n    }\n\n    # Get the minimum ratio\n    my $min_r = min($width / $wsize, $height / $hsize);\n\n    my $n_width  = sprintf('%.0f', $width / $min_r);\n    my $n_height = sprintf('%.0f', $height / $min_r);\n\n    # Create a new GD image with the new dimensions\n    my $gd = GD::Image->new($n_width, $n_height);\n    $gd->copyResampled($image, 0, 0, 0, 0, $n_width, $n_height, $width, $height);\n\n    # Create a new GD image with the wanted dimensions\n    my $cropped = GD::Image->new($wsize, $hsize);\n\n    # Crop from left and right\n    if ($n_width > $wsize) {\n        my $diff = $n_width - $wsize;\n        my $left = ceil($diff * $wcrop);\n        $cropped->copy($gd, 0, 0, $left, 0, $wsize, $hsize);\n    }\n\n    # Crop from top and bottom\n    elsif ($n_height > $hsize) {\n        my $diff = $n_height - $hsize;\n        my $top  = int($diff * $hcrop);\n        $cropped->copy($gd, 0, 0, 0, $top, $wsize, $hsize);\n    }\n\n    # No crop needed\n    else {\n        $cropped = $gd;\n    }\n\n    return $cropped;\n}\n\nmy @photo_dirs = (@ARGV ? @ARGV : usage(2));\n\n$wsize //= $size;\n$hsize //= $size;\n\nif ($wsize <= 0 or $hsize <= 0) {\n    die \"$0: size must be greater than zero (got: [$size, $wsize, $hsize])\\n\";\n}\n\nmy @images;    # stores all the image objects\n\nfind {\n    no_chdir => 1,\n    wanted   => sub {\n        if (/\\.(?:jpe?g|png)\\z/i) {\n            analyze_image($_, \\@images);\n        }\n    },\n} => @photo_dirs;\n\nmy $images_len = scalar(@images);\n\n$width  //= int(sqrt($images_len)) * $wsize;\n$height //= $width;\n\nif ($width % $wsize != 0) {\n    $width += ($wsize - ($width % $wsize));\n}\n\nif ($height % $hsize != 0) {\n    $height += ($hsize - ($height % $hsize));\n}\n\nwhile (($width / $wsize) * ($height / $hsize) > $images_len) {\n    $height -= $hsize;\n}\n\nwhile (($width / $wsize) * ($height / $hsize) < $images_len) {\n    $height += $hsize;\n}\n\nmy $collage = GD::Image->new($width, $height);\n\nforeach my $y (0 .. $height / $hsize - 1) {\n    foreach my $x (0 .. $width / $wsize - 1) {\n        my $source = shift(@images) // last;\n        $collage->copy($source, $x * $wsize, $y * $hsize, 0, 0, $wsize, $hsize);\n    }\n}\n\nopen my $fh, '>:raw', $output_file;\nprint $fh (\n             $output_file =~ /\\.png\\z/i\n           ? $collage->png(9)\n           : $collage->jpeg(90)\n          );\nclose $fh;\n"
  },
  {
    "path": "Image/complex_transform.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 31 January 2018\n# https://github.com/trizen\n\n# Complex transform of an image, by mapping each pixel position to a complex function.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse feature qw(lexical_subs);\nuse experimental qw(signatures);\n\nuse Imager;\nuse List::Util qw(min max);\nuse Math::GComplex qw(cplx);\n\nsub map_range ($this, $in_min, $in_max, $out_min, $out_max) {\n    $this =~ /[0-9]/ or return 0;\n    ($this - $in_min) * ($out_max - $out_min) / ($in_max - $in_min) + $out_min;\n}\n\nsub complex_transform ($file) {\n\n    my $img = Imager->new(file => $file);\n\n    my $width  = $img->getwidth;\n    my $height = $img->getheight;\n\n    my @vals;\n\n    foreach my $y (0 .. $height - 1) {\n        foreach my $x (0 .. $width - 1) {\n\n            my $z = cplx(\n                (2 * $x - $width) / $width,\n                (2 * $y - $height) / $height,\n            );\n\n            push @vals, [$x, $y, $z->sin->reals];\n        }\n    }\n\n    my $max_x = max(map { $_->[2] } grep { $_->[2] =~ /[0-9]/ } @vals);\n    my $max_y = max(map { $_->[3] } grep { $_->[3] =~ /[0-9]/ } @vals);\n\n    my $min_x = min(map { $_->[2] } grep { $_->[2] =~ /[0-9]/ } @vals);\n    my $min_y = min(map { $_->[3] } grep { $_->[3] =~ /[0-9]/ } @vals);\n\n    say \"X: [$min_x, $max_x]\";\n    say \"Y: [$min_y, $max_y]\";\n\n    my $new_img = Imager->new(\n        xsize => $width,\n        ysize => $height,\n    );\n\n    foreach my $val (@vals) {\n\n        $new_img->setpixel(\n            x     => sprintf('%.0f', map_range($val->[2], $min_x, $max_x, 0, $width  - 1)),\n            y     => sprintf('%.0f', map_range($val->[3], $min_y, $max_y, 0, $height - 1)),\n            color => $img->getpixel(x => $val->[0], y => $val->[1]),\n        );\n    }\n\n    return $new_img;\n}\n\nsub usage {\n    die \"usage: $0 [input image] [output image]\\n\";\n}\n\nmy $input  = shift(@ARGV) // usage();\nmy $output = shift(@ARGV) // 'complex_transform.png';\n\ncomplex_transform($input)->write(file => $output);\n"
  },
  {
    "path": "Image/cyan_vision.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 16 November 2016\n# Website: https://github.com/trizen\n\n# Redraws each pixel as a cyan colored circle.\n\n# WARNING: this process is *very* slow for large images.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager;\nuse List::Util qw(max);\n\nmy @matrix;\n\n{\n    my $img = Imager->new(file => shift(@ARGV))\n      || die die \"usage: $0 [image]\\n\";\n\n    my $height = $img->getheight - 1;\n    my $width  = $img->getwidth - 1;\n\n    foreach my $y (0 .. $height) {\n        push @matrix, [\n            map {\n                my ($r, $g, $b) = $img->getpixel(y => $y, x => $_)->rgba;\n\n                my $rgb = $r;\n                $rgb = ($rgb << 8) + $g;\n                $rgb = ($rgb << 8) + $b;\n\n                $rgb\n              } (0 .. $width)\n        ];\n    }\n}\n\nmy $max_color    = 2**16 - 1;                          # normal color is: 2**24 - 1\nmy $scale_factor = 3;                                  # the scaling factor does not affect the performance\nmy $radius       = $scale_factor / atan2(0, -'inf');\nmy $space        = $radius / 2;\n\nmy $img = Imager->new(\n                      xsize    => @{$matrix[0]} * $scale_factor,\n                      ysize    => @matrix * $scale_factor,\n                      channels => 3,\n                     );\n\nmy $max = max(map { @$_ } @matrix);\n\nforeach my $i (0 .. $#matrix) {\n    my $row = $matrix[$i];\n    foreach my $j (0 .. $#{$row}) {\n        $img->circle(\n                     r     => $radius,\n                     x     => $j * $scale_factor + $radius + $space,\n                     y     => $i * $scale_factor + $radius + $space,\n                     color => sprintf(\"#%06x\", $row->[$j] / $max * $max_color),\n                    );\n    }\n}\n\n$img->write(file => 'cyan_image.png');\n"
  },
  {
    "path": "Image/darken_image.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 07 November 2015\n# Website: https://github.com/trizen\n\n# Replace the light-color pixels with their darken neighbors.\n\n#   _________________\n#  |     |     |     |\n#  |  A  |  B  |  C  |\n#  |_____|_____|_____|         _____\n#  |     |     |     |        |     |\n#  |  H  |     |  D  |   -->  |  M  |\n#  |_____|_____|_____|        |_____|\n#  |     |     |     |\n#  |  G  |  F  |  E  |\n#  |_____|_____|_____|\n\n# where M is the darkest color from (A, B, C, D, E, F, G, H)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse List::Util qw(min);\n\nuse GD;\nGD::Image->trueColor(1);\n\nsub help {\n    my ($exit_code) = @_;\n\n    print <<\"EOT\";\nusage: $0 [input image] [output image]\nEOT\n\n    exit($exit_code // 0);\n}\n\nmy $in_file  = shift(@ARGV) // help(2);\nmy $out_file = shift(@ARGV) // 'output.png';\n\nmy $img = GD::Image->new($in_file);\n\nmy @matrix = ([]);\nmy ($width, $height) = $img->getBounds;\n\nmy $new_img = GD::Image->new($width, $height);\n\nsub get_pixel {\n    $img->rgb($img->getPixel(@_));\n}\n\nforeach my $y (1 .. $height - 2) {\n    foreach my $x (1 .. $width - 2) {\n        my @left  = get_pixel($x - 1, $y);\n        my @right = get_pixel($x + 1, $y);\n\n        my @down_left  = get_pixel($x - 1, $y + 1);\n        my @down_right = get_pixel($x + 1, $y + 1);\n\n        my @up   = get_pixel($x, $y - 1);\n        my @down = get_pixel($x, $y + 1);\n\n        my @up_left  = get_pixel($x - 1, $y - 1);\n        my @up_right = get_pixel($x + 1, $y - 1);\n\n        $matrix[$y][$x] =\n          $new_img->colorAllocate(\n                                  min(($up[0], $down[0], $up_left[0], $up_right[0], $down_left[0], $down_right[0])),\n                                  min(($up[1], $down[1], $up_left[1], $up_right[1], $down_left[1], $down_right[1])),\n                                  min(($up[2], $down[2], $up_left[2], $up_right[2], $down_left[2], $down_right[2])),\n                                 );\n    }\n}\n\nfor my $y (1 .. $height - 2) {\n    for my $x (1 .. $width - 2) {\n        $new_img->setPixel($x, $y, $matrix[$y][$x]);\n    }\n}\n\nopen(my $fh, '>:raw', $out_file) or die \"Can't open `$out_file' for write: $!\";\nprint $fh (\n             $out_file =~ /\\.png\\z/i ? $new_img->png\n           : $out_file =~ /\\.gif\\z/i ? $new_img->gif\n           :                           $new_img->jpeg\n          );\nclose $fh;\n"
  },
  {
    "path": "Image/diff_negative.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 07 November 2015\n# Edit: 19 May 2016\n# Website: https://github.com/trizen\n\n# Replace the light-color pixels with the difference between the brightest and darkest neighbors.\n\n#   _________________\n#  |     |     |     |\n#  |  A  |  B  |  C  |\n#  |_____|_____|_____|         _____\n#  |     |     |     |        |     |\n#  |  H  |     |  D  |   -->  |  M  |\n#  |_____|_____|_____|        |_____|\n#  |     |     |     |\n#  |  G  |  F  |  E  |\n#  |_____|_____|_____|\n\n# where M is the average color of (max(A..H) - min(A..H))\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse List::Util qw(min max sum);\n\nuse GD;\nGD::Image->trueColor(1);\n\nsub help {\n    my ($exit_code) = @_;\n\n    print <<\"EOT\";\nusage: $0 [input image] [output image]\nEOT\n\n    exit($exit_code // 0);\n}\n\nmy $in_file  = shift(@ARGV) // help(2);\nmy $out_file = shift(@ARGV) // 'output.png';\n\nmy $img = GD::Image->new($in_file);\n\nmy @matrix = ([]);\nmy ($width, $height) = $img->getBounds;\n\nmy $new_img = GD::Image->new($width, $height);\n\nsub diff {\n    max(@_) - min(@_);\n}\n\nsub avg {\n    (int(sum(@_) / @_)) x 3;\n}\n\nsub get_pixel {\n    $img->rgb($img->getPixel(@_))\n}\n\nforeach my $y (1 .. $height - 2) {\n    foreach my $x (1 .. $width - 2) {\n        my @left  = get_pixel($x - 1, $y);\n        my @right = get_pixel($x + 1, $y);\n\n        my @down_left  = get_pixel($x - 1, $y + 1);\n        my @down_right = get_pixel($x + 1, $y + 1);\n\n        my @up   = get_pixel($x, $y - 1);\n        my @down = get_pixel($x, $y + 1);\n\n        my @up_left  = get_pixel($x - 1, $y - 1);\n        my @up_right = get_pixel($x + 1, $y - 1);\n\n        $matrix[$y][$x] =\n          $new_img->colorAllocate(\n                                  avg(\n                                      diff(($up[0], $down[0], $up_left[0], $up_right[0], $down_left[0], $down_right[0])),\n                                      diff(($up[1], $down[1], $up_left[1], $up_right[1], $down_left[1], $down_right[1])),\n                                      diff(($up[2], $down[2], $up_left[2], $up_right[2], $down_left[2], $down_right[2]))\n                                     ),\n                                 );\n    }\n}\n\nfor my $y (1 .. $height - 2) {\n    for my $x (1 .. $width - 2) {\n        $new_img->setPixel($x, $y, $matrix[$y][$x]);\n    }\n}\n\nopen(my $fh, '>:raw', $out_file) or die \"Can't open `$out_file' for write: $!\";\nprint $fh (\n             $out_file =~ /\\.png\\z/i ? $new_img->png\n           : $out_file =~ /\\.gif\\z/i ? $new_img->gif\n           :                           $new_img->jpeg\n          );\nclose $fh;\n"
  },
  {
    "path": "Image/edge_detector.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 05 November 2015\n# Edit: 19 May 2016\n# Website: https://github.com/trizen\n\n# A very basic edge detector, which highlights the edges in an image.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse GD;\nGD::Image->trueColor(1);\n\nuse List::Util qw(sum);\nuse Getopt::Long qw(GetOptions);\n\nmy $tolerance = 15;    # lower tolerance => more noise\n\nGetOptions('t|tolerance=f' => \\$tolerance,\n           'h|help'        => sub { help(0) })\n  or die \"Error in command-line arguments!\";\n\nsub help {\n    my ($exit_code) = @_;\n\n    print <<\"EOT\";\nusage: $0 [options] [input image] [output image]\n\noptions:\n    -t  --tolerance=[0-100] : tolerance value for edges (default: $tolerance)\n                              lower values will generate more noise\n\nexample:\n    perl $0 -t=5 input.png output.png\nEOT\n\n    exit($exit_code // 0);\n}\n\nmy $in_file  = shift(@ARGV) // help(2);\nmy $out_file = shift(@ARGV) // 'output.png';\n\nmy $img = GD::Image->new($in_file);\n\nmy @matrix = ([]);\nmy ($width, $height) = $img->getBounds;\n\nsub get_avg_pixel {\n    sum($img->rgb($img->getPixel(@_))) / 3;\n}\n\n# Detect edge\nforeach my $y (1 .. $height - 2) {\n    foreach my $x (1 .. $width - 2) {\n        if (   abs(get_avg_pixel($x-1, $y  ) - get_avg_pixel($x+1, $y  )) / 255 * 100 > $tolerance      # left     <-> right\n            or abs(get_avg_pixel($x,   $y-1) - get_avg_pixel($x,   $y+1)) / 255 * 100 > $tolerance      # up       <-> down\n            or abs(get_avg_pixel($x-1, $y-1) - get_avg_pixel($x+1, $y+1)) / 255 * 100 > $tolerance      # up-left  <-> down-right\n            or abs(get_avg_pixel($x+1, $y-1) - get_avg_pixel($x-1, $y+1)) / 255 * 100 > $tolerance      # up-right <-> down-left\n            ) {\n            $matrix[$y][$x] = 1;\n        }\n    }\n}\n\n# Remove noise\nforeach my $y (1 .. $height - 2) {\n    foreach my $x (1 .. $width - 2) {\n        if (defined($matrix[$y][$x])) {\n            if (!defined($matrix[$y  ][$x+1])\n            and !defined($matrix[$y  ][$x-1])\n            and !defined($matrix[$y-1][$x-1])\n            and !defined($matrix[$y-1][$x  ])\n            and !defined($matrix[$y-1][$x+1])\n            and !defined($matrix[$y+1][$x-1])\n            and !defined($matrix[$y+1][$x  ])\n            and !defined($matrix[$y+1][$x+1])\n        ) {\n                undef $matrix[$y][$x];\n          }\n        }\n    }\n}\n\nmy $new_img = GD::Image->new($width, $height);\n\nmy $bg_color = $new_img->colorAllocate(0,   0,   0);\nmy $fg_color = $new_img->colorAllocate(255, 255, 255);\n\nfor my $y (0 .. $height - 1) {\n    for my $x (0 .. $width - 1) {\n        $new_img->setPixel($x, $y, defined($matrix[$y][$x]) ? $fg_color : $bg_color);\n    }\n}\n\nopen(my $fh, '>:raw', $out_file) or die \"Can't open `$out_file' for write: $!\";\nprint $fh (\n             $out_file =~ /\\.png\\z/i ? $new_img->png\n           : $out_file =~ /\\.gif\\z/i ? $new_img->gif\n           :                           $new_img->jpeg\n          );\nclose $fh;\n"
  },
  {
    "path": "Image/extract_jpegs.pl",
    "content": "#!/usr/bin/perl\n\n# Unpack two or more concatenated JPEG files.\n\n# See also:\n#   https://stackoverflow.com/questions/4585527/detect-end-of-file-for-jpg-images\n\nuse 5.014;\nuse strict;\nuse warnings;\n\nuse Digest::MD5 qw(md5_hex);\n\nbinmode(STDIN,  ':raw');\nbinmode(STDOUT, ':raw');\n\nmy $data = do {\n    local $/;\n    <>;\n};\n\n#my @files = split(/\\x{FF}\\x{D8}/, $data);\n#my @files = split(/^\\xFF\\xD8/m, $data);\n\nmy $count = 1;\n\n#$data = reverse($data);\n\n#foreach my $data (@files) {\nwhile ($data =~ /(\\xFF\\xD8.*?\\xFF\\xD9)/gs) {\n    my $jpeg = $1;\n    my $name = sprintf(\"file_%d %s.jpg\", $count++, md5_hex($jpeg));\n    open my $fh, '>:raw', $name\n      or die \"Can't open <<$name>>: $!\";\n    print $fh $jpeg;\n    close $fh;\n}\n"
  },
  {
    "path": "Image/fractal_frame.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 25 January 2018\n# https://github.com/trizen\n\n# Adds a Mandelbrot-like fractal frame around the edges of an image.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse feature qw(lexical_subs);\nuse experimental qw(signatures);\n\nuse Imager;\nuse Math::GComplex qw(cplx);\n\nsub complex_transform ($file) {\n\n    my $img   = Imager->new(file => $file);\n    my $black = Imager::Color->new('#000000');\n\n    my $width  = $img->getwidth;\n    my $height = $img->getheight;\n\n    my sub mandelbrot ($x, $y) {\n\n        my $z = cplx(\n            (2 * $x - $width)  / $width,\n            (2 * $y - $height) / $height,\n        );\n\n        my $c = $z;\n        my $i = 10;\n\n        while (abs($z) < 2 and --$i) {\n            $z = $z->pown(5) + $c;\n        }\n\n        return $i;\n    }\n\n    foreach my $y (0 .. $height - 1) {\n        foreach my $x (0 .. $width - 1) {\n\n            next if (mandelbrot($x, $y) == 0);\n\n            $img->setpixel(\n                           x     => $x,\n                           y     => $y,\n                           color => $black,\n                          );\n        }\n    }\n\n    return $img;\n}\n\nsub usage {\n    die \"usage: $0 [input image] [output image]\\n\";\n}\n\nmy $input  = shift(@ARGV) // usage();\nmy $output = shift(@ARGV) // 'fractal_frame.png';\n\ncomplex_transform($input)->write(file => $output);\n"
  },
  {
    "path": "Image/fractal_frame_transparent.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 27 January 2018\n# https://github.com/trizen\n\n# Adds a transparent Mandelbrot-like fractal frame around the edges of an image.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse feature qw(lexical_subs);\nuse experimental qw(signatures);\n\nuse Imager;\nuse Math::GComplex qw(cplx);\n\nsub complex_transform ($file) {\n\n    my $img = Imager->new(file => $file);\n\n    my $width  = $img->getwidth;\n    my $height = $img->getheight;\n\n    my $max_iter = 10;\n\n    my sub mandelbrot ($x, $y) {\n\n        my $z = cplx(\n            (2 * $x - $width) / $width,\n            (2 * $y - $height) / $height,\n        );\n\n        my $c = $z;\n        my $i = $max_iter;\n\n        while (abs($z) < 2 and --$i) {\n            $z = $z->pown(5) + $c;\n        }\n\n        ($max_iter - $i) / $max_iter;\n    }\n\n    foreach my $y (0 .. $height - 1) {\n        foreach my $x (0 .. $width - 1) {\n\n            my $i = mandelbrot($x, $y);\n\n            my $pixel = $img->getpixel(x => $x, y => $y);\n            my ($red, $green, $blue, $alpha) = $pixel->rgba();\n\n            $red   *= $i;\n            $green *= $i;\n            $blue  *= $i;\n            $alpha *= $i;\n\n            $pixel->set($red, $green, $blue, $alpha);\n\n            $img->setpixel(\n                x     => $x,\n                y     => $y,\n                color => $pixel,\n            );\n        }\n    }\n\n    return $img;\n}\n\nsub usage {\n    die \"usage: $0 [input image] [output image]\\n\";\n}\n\nmy $input  = shift(@ARGV) // usage();\nmy $output = shift(@ARGV) // 'fractal_frame.png';\n\ncomplex_transform($input)->write(file => $output);\n"
  },
  {
    "path": "Image/gd_png2jpg.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 23 March 2021\n# https://github.com/trizen\n\n# Convert PNG images to JPEG, using the GD library.\n\n# The original PNG files are deleted.\n\nuse 5.036;\n\nuse GD;\nuse File::Find   qw(find);\nuse Getopt::Long qw(GetOptions);\n\nGD::Image->trueColor(1);\n\nmy $batch_size   = 100;    # how many files to process at once\nmy $quality      = 95;     # default quality value for JPEG (between 0-100)\nmy $use_exiftool = 0;      # true to use `exiftool` instead of `File::MimeInfo::Magic`\n\nsub convert_PNGs (@files) {\n\n    say \":: Converting a batch of \", scalar(@files), \" PNG images...\";\n\n    foreach my $file (@files) {\n        say \":: Processing: $file\";\n\n        my $image = eval { GD::Image->new($file) } // do {\n            warn \"[!] Can't load file <<$file>>. Skipping...\\n\";\n            next;\n        };\n\n        my $jpeg_data = $image->jpeg($quality);\n\n        my $orig_file = $file;\n        my $jpeg_file = $file;\n\n        if ($jpeg_file =~ s/\\.png\\z/.jpg/i) {\n            ## ok\n        }\n        else {\n            $jpeg_file .= '.jpg';\n        }\n\n        if (-e $jpeg_file) {\n            warn \"[!] File <<$jpeg_file>> already exists...\\n\";\n            next;\n        }\n\n        open(my $fh, '>:raw', $jpeg_file) or do {\n            warn \"[!] Can't open file <<$jpeg_file>> for writing: $!\\n\";\n            next;\n        };\n\n        print {$fh} $jpeg_data;\n        close $fh;\n\n        if (-e $jpeg_file and ($orig_file ne $jpeg_file)) {\n            say \":: Saved as: $jpeg_file\";\n            unlink($orig_file);    # remove the original PNG file\n        }\n    }\n}\n\nsub determine_mime_type ($file) {\n\n    if ($use_exiftool) {\n        my $res = `exiftool \\Q$file\\E`;\n        $? == 0       or return;\n        defined($res) or return;\n        if ($res =~ m{^MIME\\s+Type\\s*:\\s*(\\S+)}mi) {\n            return $1;\n        }\n        return;\n    }\n\n    require File::MimeInfo::Magic;\n    File::MimeInfo::Magic::magic($file);\n}\n\nmy %types = (\n             'image/png' => {\n                             files => [],\n                             call  => \\&convert_PNGs,\n                            },\n            );\n\nGetOptions(\n           'exiftool!'    => \\$use_exiftool,\n           'batch-size=i' => \\$batch_size,\n           'q|quality=i'  => \\$quality,\n          )\n  or die \"Error in command-line arguments!\";\n\n@ARGV or die <<\"USAGE\";\nusage: perl $0 [options] [dirs | files]\n\noptions:\n\n    -q INT     : quality level for JPEG (default: $quality)\n    --batch=i  : how many files to process at once (default: $batch_size)\n    --exiftool : use `exiftool` to determine the MIME type (default: $use_exiftool)\n\nUSAGE\n\nfind(\n    {\n     no_chdir => 1,\n     wanted   => sub {\n\n         (-f $_) || return;\n         my $type = determine_mime_type($_) // return;\n\n         if (exists $types{$type}) {\n\n             my $ref = $types{$type};\n             push @{$ref->{files}}, $_;\n\n             if (scalar(@{$ref->{files}}) >= $batch_size) {\n                 $ref->{call}->(splice(@{$ref->{files}}));\n             }\n         }\n     }\n    } => @ARGV\n);\n\nforeach my $type (keys %types) {\n\n    my $ref = $types{$type};\n\n    if (@{$ref->{files}}) {\n        $ref->{call}->(splice(@{$ref->{files}}));\n    }\n}\n\nsay \":: Done!\";\n"
  },
  {
    "path": "Image/gd_similar_images.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 26 August 2015\n# Edit: 24 October 2023\n# Website: https://github.com/trizen\n\n# Find images that look similar.\n\n# Blog post:\n#   https://trizenx.blogspot.com/2015/08/finding-similar-images.html\n\nuse 5.022;\nuse strict;\nuse warnings;\n\nuse experimental 'bitwise';\n\nuse GD           qw();\nuse List::Util   qw(sum);\nuse File::Find   qw(find);\nuse Getopt::Long qw(GetOptions);\n\nGD::Image->trueColor(1);\n\nmy $width      = 32;\nmy $height     = 32;\nmy $percentage = 90;\n\nmy $keep_only   = undef;\nmy $img_formats = '';\nmy $resize_to   = $width . 'x' . $height;\n\nmy @img_formats = qw(\n  jpeg\n  jpg\n  png\n);\n\nsub help {\n    my ($code) = @_;\n    local $\" = \",\";\n    print <<\"EOT\";\nusage: $0 [options] [dir]\n\noptions:\n    -p  --percentage=i  : minimum similarity percentage (default: $percentage)\n    -r  --resize-to=s   : resize images to this resolution (default: $resize_to)\n    -f  --formats=s,s   : specify more image formats (default: @img_formats)\n    -k  --keep=s        : keep only the 'smallest' or 'largest' image from each group\n\nWARNING: option '-k' permanently removes your images!\n\nexample:\n    perl $0 -p 75 -r '8x8' ~/Pictures\nEOT\n\n    exit($code);\n}\n\nGetOptions(\n           'p|percentage=i' => \\$percentage,\n           'r|resize-to=s'  => \\$resize_to,\n           'f|formats=s'    => \\$img_formats,\n           'k|keep=s'       => \\$keep_only,\n           'h|help'         => sub { help(0) },\n          )\n  or die(\"Error in command line arguments\");\n\n($width, $height) = split(/\\h*x\\h*/i, $resize_to);\n\nmy $size = $width * $height;\npush @img_formats, map { quotemeta } split(/\\s*,\\s*/, $img_formats);\n\nmy $img_formats_re = do {\n    local $\" = '|';\n    qr/\\.(@img_formats)\\z/i;\n};\n\n#<<<\nsub alike_percentage {\n    ((($_[0] ^. $_[1]) =~ tr/\\0//) / $size)**2 * 100;\n}\n#>>>\n\nsub fingerprint {\n    my ($image) = @_;\n\n    my $img = GD::Image->new($image) // return;\n\n    {\n        my $resized = GD::Image->new($width, $height);\n        $resized->copyResampled($img, 0, 0, 0, 0, $width, $height, $img->getBounds());\n        $img = $resized;\n    }\n\n    my @averages;\n    foreach my $y (0 .. $height - 1) {\n        foreach my $x (0 .. $width - 1) {\n            push @averages, sum($img->rgb($img->getPixel($x, $y)))/3;\n        }\n    }\n\n    my $avg = sum(@averages) / @averages;\n    join('', map { ($_ < $avg) ? 1 : 0 } @averages);\n}\n\nsub find_similar_images(&@) {\n    my $callback = shift;\n\n    my @files;\n    find {\n        no_chdir => 1,\n        wanted   => sub {\n            (/$img_formats_re/o && -f) || return;\n\n            push @files,\n              {\n                fingerprint => fingerprint($_) // return,\n                filename    => $_,\n              };\n        }\n    } => @_;\n\n    #\n    ## Populate the %alike hash\n    #\n    my %alike;\n    foreach my $i (0 .. $#files - 1) {\n        for (my $j = $i + 1 ; $j <= $#files ; $j++) {\n            my $p = alike_percentage($files[$i]{fingerprint}, $files[$j]{fingerprint});\n            if ($p >= $percentage) {\n                $alike{$files[$i]{filename}}{$files[$j]{filename}} = $p;\n                $alike{$files[$j]{filename}}{$files[$i]{filename}} = $p;\n            }\n        }\n    }\n\n    #\n    ## Group the files\n    #\n    my @alike;\n    foreach my $root (\n        map  { $_->[0] }\n        sort { ($a->[1] <=> $b->[1]) || ($b->[2] <=> $a->[2]) }\n        map {\n            my $keys = keys(%{$alike{$_}});\n            my $avg  = sum(values(%{$alike{$_}})) / $keys;\n\n            [$_, $keys, $avg]\n        }\n        keys %alike\n      ) {\n        my @group = keys(%{$alike{$root}});\n        if (@group) {\n            my $avg = 0;\n            $avg += delete($alike{$_}{$root}) for @group;\n            push @alike, {score => $avg / @group, files => [$root, @group]};\n\n        }\n    }\n\n    #\n    ## Callback each group\n    #\n    my %seen;\n    foreach my $group (sort { $b->{score} <=> $a->{score} } @alike) {\n        (@{$group->{files}} == grep { $seen{$_}++ } @{$group->{files}}) and next;\n        $callback->($group->{score}, $group->{files});\n    }\n\n    return 1;\n}\n\n@ARGV || help(1);\nfind_similar_images {\n    my ($score, $files) = @_;\n\n    printf(\"=> Similarity: %.0f%%\\n\", $score);\n    say join(\"\\n\", sort @{$files});\n    say \"-\" x 80;\n\n    if (defined($keep_only)) {\n\n        my @existent_files = grep { -f $_ } @$files;\n\n        scalar(@existent_files) > 1 or return;\n\n        my @sorted_by_size = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [$_, -s $_] } @existent_files;\n        if ($keep_only =~ /large/i) {\n            pop(@sorted_by_size);\n        }\n        elsif ($keep_only =~ /small/i) {\n            shift(@sorted_by_size);\n        }\n        else {\n            die \"error: unknown value <<$keep_only>> for option `-k`!\\n\";\n        }\n        foreach my $file (@sorted_by_size) {\n            say \"Removing: $file\";\n            unlink($file) or warn \"Failed to remove: $!\";\n        }\n    }\n} @ARGV;\n"
  },
  {
    "path": "Image/gd_star_trails.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 30 January 2015\n# Edited: 31 January 2015\n# Website: https://github.com/trizen\n\n# Merge two or more images together and keep the most intensive pixel colors\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse GD;\nuse Getopt::Long qw(GetOptions);\n\nGD::Image->trueColor(1);\n\nmy $output_file = 'output.png';\nmy $file_format = 'png';\n\nmy $png_compression = 9;\nmy $jpeg_quality    = 90;\n\nmy $scale_percent = 0;\n\nsub help {\n    print <<\"HELP\";\nusage: $0 [options] [files]\n\noptions:\n    -o  --output          : output file (default: $output_file)\n    -f  --format          : image format (default: $file_format)\n    -q  --jpeg-quality    : JPEG quality (default: $jpeg_quality)\n    -c  --png-compression : PNG compression level (default: $png_compression)\n    -s  --scale-percent   : scale image by a given percentage (default: $scale_percent)\n\nexample:\n    $0 -o merged.png --scale -20 file1.jpg file2.jpg\nHELP\n    exit;\n}\n\nGetOptions(\n           'o|output=s'          => \\$output_file,\n           'f|format=s'          => \\$file_format,\n           'q|jpeg-quality=i'    => \\$jpeg_quality,\n           'c|png-compression=i' => \\$png_compression,\n           's|scale-percent=i'   => \\$scale_percent,\n           'h|help'              => \\&help,\n          )\n  or die \"Error in command-line arguments!\";\n\nsub intensity {\n    ($_[0] + $_[1] + $_[2]) / 3;\n}\n\nmy @matrix;\nmy %color_cache;\nmy %intensity_cache;\n\nforeach my $image (@ARGV) {\n\n    say \"** Processing file: $image\";\n\n    my $gd = GD::Image->new($image) // do {\n        warn \"** Can't load file <<$image>>. Skipping...\\n\";\n        next;\n    };\n\n    my ($width, $height) = $gd->getBounds;\n\n    if ($scale_percent != 0) {\n        my $scale_width  = $width + int($scale_percent / 100 * $width);\n        my $scale_height = $height + int($scale_percent / 100 * $height);\n\n        my $scaled_gd = GD::Image->new($scale_width, $scale_height);\n        $scaled_gd->copyResampled($gd, 0, 0, 0, 0, $scale_width, $scale_height, $width, $height);\n\n        ($width, $height) = ($scale_width, $scale_height);\n        $gd = $scaled_gd;\n    }\n\n    foreach my $x (0 .. $width - 1) {\n        foreach my $y (0 .. $height - 1) {\n            my $index = $gd->getPixel($x, $y);\n            $matrix[$x][$y] //= [0, 0, 0];\n            if (intensity(@{$matrix[$x][$y]}) <\n                ($intensity_cache{$index} //= (intensity(@{$color_cache{$index} //= [$gd->rgb($index)]})))) {\n                $matrix[$x][$y] = $color_cache{$index};\n            }\n        }\n    }\n}\n\n@matrix || die \"error: No image has been processed!\\n\";\nsay \"** Creating the output image: $output_file\";\n\nmy $image = GD::Image->new($#matrix + 1, $#{$matrix[0]} + 1);\nforeach my $x (0 .. $#matrix) {\n    my $row = $matrix[$x] // next;\n    foreach my $y (0 .. $#{$matrix[0]}) {\n        my $entry = $row->[$y] // next;\n        my $color = $image->colorAllocate(@{$entry});\n        $image->setPixel($x, $y, $color);\n    }\n}\n\nopen my $fh, '>:raw', $output_file;\nprint $fh lc($file_format) =~ /png/\n  ? $image->png($png_compression)\n  : $image->jpeg($jpeg_quality);\nclose $fh;\n\nsay \"** All done!\";\n"
  },
  {
    "path": "Image/gif2webp.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 14 October 2023\n# https://github.com/trizen\n\n# Convert GIF animations to WEBP animations, using the `gif2webp` tool from \"libwebp\".\n\n# The original GIF files are deleted.\n\nuse 5.036;\nuse File::Find   qw(find);\nuse Getopt::Long qw(GetOptions);\n\nmy $gif2webp_cmd = \"gif2webp\";    # `gif2webp` command\nmy $use_exiftool = 0;             # true to use `exiftool` instead of `File::MimeInfo::Magic`\n\n`$gif2webp_cmd -h`\n  or die \"Error: `$gif2webp_cmd` tool from 'libwebp' is not installed!\\n\";\n\nsub gif2webp ($file) {\n\n    my $orig_file = $file;\n    my $webp_file = $file;\n\n    if ($webp_file =~ s/\\.gif\\z/.webp/i) {\n        ## ok\n    }\n    else {\n        $webp_file .= '.webp';\n    }\n\n    if (-e $webp_file) {\n        warn \"[!] File <<$webp_file>> already exists...\\n\";\n        next;\n    }\n\n    system($gif2webp_cmd, '-lossy', $orig_file, '-o', $webp_file);\n\n    if ($? == 0 and (-e $webp_file) and ($webp_file ne $orig_file)) {\n        unlink($orig_file);\n    }\n    else {\n        return;\n    }\n\n    return 1;\n}\n\nsub determine_mime_type ($file) {\n\n    if ($file =~ /\\.gif\\z/i) {\n        return \"image/gif\";\n    }\n\n    if ($use_exiftool) {\n        my $res = `exiftool \\Q$file\\E`;\n        $? == 0       or return;\n        defined($res) or return;\n        if ($res =~ m{^MIME\\s+Type\\s*:\\s*(\\S+)}mi) {\n            return $1;\n        }\n        return;\n    }\n\n    require File::MimeInfo::Magic;\n    File::MimeInfo::Magic::magic($file);\n}\n\nmy %types = (\n             'image/gif' => {\n                             call => \\&gif2webp,\n                            },\n            );\n\nGetOptions('exiftool!' => \\$use_exiftool,)\n  or die \"Error in command-line arguments!\";\n\n@ARGV or die <<\"USAGE\";\nusage: $0 [options] [dirs | files]\n\noptions:\n\n    --exiftool : use `exiftool` to determine the MIME type (default: $use_exiftool)\n\nUSAGE\n\nfind(\n    {\n     no_chdir => 1,\n     wanted   => sub {\n\n         (-f $_) || return;\n         my $type = determine_mime_type($_) // return;\n\n         if (exists $types{$type}) {\n             $types{$type}{call}->($_);\n         }\n     }\n    } => @ARGV\n);\n\nsay \":: Done!\";\n"
  },
  {
    "path": "Image/horizontal_scrambler.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 05 April 2024\n# https://github.com/trizen\n\n# Scramble the pixels in each row inside an image, using a deterministic method.\n\nuse 5.036;\nuse GD;\nuse Getopt::Std qw(getopts);\n\nGD::Image->trueColor(1);\n\nsub scramble ($str) {\n    my $i = length($str);\n    $str =~ s/(.{$i})(.)/$2$1/gs while (--$i > 0);\n    return $str;\n}\n\nsub unscramble ($str) {\n    my $i = 0;\n    my $l = length($str);\n    $str =~ s/(.)(.{$i})/$2$1/gs while (++$i < $l);\n    return $str;\n}\n\nsub scramble_image ($file, $function) {\n\n    my $image = GD::Image->new($file) || die \"Can't open file <<$file>>: $!\";\n    my ($width, $height) = $image->getBounds();\n\n    my $new_image = GD::Image->new($width, $height);\n\n    foreach my $y (0 .. $height - 1) {\n\n        my (@R, @G, @B);\n        foreach my $x (0 .. $width - 1) {\n            my ($R, $G, $B) = $image->rgb($image->getPixel($x, $y));\n            push @R, $R;\n            push @G, $G;\n            push @B, $B;\n        }\n\n        @R = unpack('C*', $function->(pack('C*', @R)));\n        @G = unpack('C*', $function->(pack('C*', @G)));\n        @B = unpack('C*', $function->(pack('C*', @B)));\n\n        foreach my $x (0 .. $width - 1) {\n            $new_image->setPixel($x, $y, $new_image->colorAllocate($R[$x], $G[$x], $B[$x]));\n        }\n    }\n\n    return $new_image;\n}\n\nsub usage ($exit_code = 0) {\n\n    print <<\"EOT\";\nusage: $0 [options] [input.png] [output.png]\n\noptions:\n\n    -d : decode the image\n    -h : print this message and exit\n\nEOT\n\n    exit($exit_code);\n}\n\ngetopts('dh', \\my %opts);\n\nmy $input_file  = $ARGV[0] // usage(2);\nmy $output_file = $ARGV[1] // \"output.png\";\n\nif (not -f $input_file) {\n    die \"Input file <<$input_file>> does not exist!\\n\";\n}\n\nmy $img = $opts{d} ? scramble_image($input_file, \\&unscramble) : scramble_image($input_file, \\&scramble);\nopen(my $out_fh, '>:raw', $output_file) or die \"can't create output file <<$output_file>>: $!\";\nprint $out_fh $img->png(9);\nclose $out_fh;\n"
  },
  {
    "path": "Image/image-hard-rotate.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 10 August 2025\n# Edit: 23 Setepmber 2025\n# https://github.com/trizen\n\n# Hard-rotate images that contain the \"Orientation\" EXIF tag specified as \"Rotate 90 CW\" or \"Rotate 270 CW\".\n\nuse 5.036;\nuse Imager;\nuse Image::ExifTool qw(ImageInfo);\nuse File::Find      qw(find);\nuse Getopt::Long    qw(GetOptions);\n\nmy $img_formats   = '';\nmy $preserve_attr = 0;\n\nmy @img_formats = qw(\n  jpeg\n  jpg\n);\n\nsub usage ($code) {\n    local $\" = \",\";\n    print <<\"EOT\";\nusage: $0 [options] [dirs | files]\n\noptions:\n    -f  --formats=s,s : specify more image formats (default: @img_formats)\n    -p  --preserve!   : preserve original file timestamps and permissions\n\nexamples:\n\n    $0 -p *.jpg\n\nEOT\n\n    exit($code);\n}\n\nGetOptions(\n           'f|formats=s' => \\$img_formats,\n           'p|preserve!' => \\$preserve_attr,\n           'help'        => sub { usage(0) },\n          )\n  or die(\"Error in command line arguments\");\n\nsub hard_rotate_image ($file) {\n\n    my $info        = ImageInfo($file);\n    my $orientation = $info->{Orientation};\n\n    if (defined($orientation) and $orientation =~ /^Rotate (\\d+) CW/) {\n\n        my $angle = $1;\n        say \"-> Rotating image by $angle degrees clockwise...\";\n\n        my $img = Imager->new(file => $file) or die Imager->errstr();\n        $img = $img->rotate(degrees => $angle);\n\n        my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks) = stat($file);\n\n        unlink($file);\n        $img->write(file => $file) or do {\n            warn \"Failed to rewrite image: \", $img->errstr;\n            return;\n        };\n\n        # Set the original ownership of the image\n        chown($uid, $gid, $file);\n\n        if ($preserve_attr) {\n\n            # Set the original modification time\n            utime($atime, $mtime, $file)\n              or warn \"Can't change timestamp: $!\\n\";\n\n            # Set original permissions\n            chmod($mode & 07777, $file)\n              or warn \"Can't change permissions: $!\\n\";\n        }\n\n    }\n}\n\n@ARGV || usage(1);\n\npush @img_formats, map { quotemeta } split(/\\s*,\\s*/, $img_formats);\n\nmy $img_formats_re = do {\n    local $\" = '|';\n    qr/\\.(@img_formats)\\z/i;\n};\n\nfind {\n    no_chdir => 1,\n    wanted   => sub {\n        (/$img_formats_re/o && -f) || return;\n        say \":: Processing: $_\";\n        hard_rotate_image($_);\n    }\n} => @ARGV;\n"
  },
  {
    "path": "Image/image-unpack.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 29 April 2025\n# https://github.com/trizen\n\n# Extract the {R,G,B} channels of an image, as binary data.\n\nuse 5.036;\nuse GD           qw();\nuse Getopt::Long qw(GetOptions);\n\nbinmode(STDOUT, ':raw');\n\nGD::Image->trueColor(1);\n\nmy $size  = 80;\nmy $red   = 0;\nmy $green = 0;\nmy $blue  = 0;\n\nsub help($code = 0) {\n    print <<\"HELP\";\nusage: $0 [options] [files]\n\noptions:\n    -w  --width=i : resize image to this width (default: $size)\n    -R  --red     : extract only the RED channel (default: $red)\n    -G  --green   : extract only the GREEN channel (default: $green)\n    -B  --blue    : extract only the BLUE channel (default: $blue)\n\nexample:\n    perl $0 --width 200 --red image.png > red_channel.bin\nHELP\n    exit($code);\n}\n\nGetOptions(\n           'w|width=s' => \\$size,\n           'R|red!'    => \\$red,\n           'G|green!'  => \\$green,\n           'B|blue!'   => \\$blue,\n           'h|help'    => sub { help(0) },\n          )\n  or die \"Error in command-line arguments!\";\n\nsub img_unpack($image) {\n\n    my $img = GD::Image->new($image) // return;\n    my ($width, $height) = $img->getBounds;\n\n    if ($size != 0) {\n        my $scale_width  = $size;\n        my $scale_height = int($height / ($width / ($size / 2)));\n\n        my $resized = GD::Image->new($scale_width, $scale_height);\n        $resized->copyResampled($img, 0, 0, 0, 0, $scale_width, $scale_height, $width, $height);\n\n        ($width, $height) = ($scale_width, $scale_height);\n        $img = $resized;\n    }\n\n    my @values;\n\n    foreach my $y (0 .. $height - 1) {\n        foreach my $x (0 .. $width - 1) {\n            my $index = $img->getPixel($x, $y);\n            my ($R, $G, $B) = $img->rgb($index);\n\n            if ($red) {\n                push @values, $R;\n            }\n            if ($green) {\n                push @values, $G;\n            }\n            if ($blue) {\n                push @values, $B;\n            }\n        }\n    }\n\n    my $output_width = $width * ($red + $green + $blue);\n    return unpack(\"(A$output_width)*\", pack('C*', @values));\n}\n\nprint for img_unpack($ARGV[0] // help(1));\n"
  },
  {
    "path": "Image/image2ascii.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 27 August 2015\n# Website: https://github.com/trizen\n\n# Generate an ASCII representation for an image\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse GD qw();\nuse Getopt::Long qw(GetOptions);\n\nGD::Image->trueColor(1);\n\nmy $size = 80;\n\nsub help {\n    my ($code) = @_;\n    print <<\"HELP\";\nusage: $0 [options] [files]\n\noptions:\n    -w  --width=i : width size of the ASCII image (default: $size)\n\nexample:\n    perl $0 --width 200 image.png\nHELP\n    exit($code);\n}\n\nGetOptions('w|width=s' => \\$size,\n           'h|help'    => sub { help(0) },)\n  or die \"Error in command-line arguments!\";\n\nsub avg {\n    ($_[0] + $_[1] + $_[2]) / 3;\n}\n\nsub img2ascii {\n    my ($image) = @_;\n\n    my $img = GD::Image->new($image) // return;\n    my ($width, $height) = $img->getBounds;\n\n    if ($size != 0) {\n        my $scale_width = $size;\n        my $scale_height = int($height / ($width / ($size / 2)));\n\n        my $resized = GD::Image->new($scale_width, $scale_height);\n        $resized->copyResampled($img, 0, 0, 0, 0, $scale_width, $scale_height, $width, $height);\n\n        ($width, $height) = ($scale_width, $scale_height);\n        $img = $resized;\n    }\n\n    my $avg = 0;\n    my @averages;\n\n    foreach my $y (0 .. $height - 1) {\n        foreach my $x (0 .. $width - 1) {\n            my $index = $img->getPixel($x, $y);\n            push @averages, avg($img->rgb($index));\n            $avg += $averages[-1] / $width / $height;\n        }\n    }\n\n    unpack(\"(A$width)*\", join('', map { $_ < $avg ? 1 : 0 } @averages));\n}\n\nsay for img2ascii($ARGV[0] // help(1));\n"
  },
  {
    "path": "Image/image2audio.pl",
    "content": "#!/usr/bin/perl\n\n# Convert an image to an audio spectrogram.\n\n# Algorithm from:\n#   https://github.com/alexadam/img-encode/blob/master/v1-python/imgencode.py\n\n# The spectrogram can be viewed in a program, like Audacity.\n\n# Inspired by the hidden message in the movie \"Leave the world behind\":\n#   https://www.reddit.com/r/MrRobot/comments/18hnn3q/minor_spoiler_leave_the_world_behind_hidden/\n\nuse 5.036;\nuse Imager;\nuse Audio::Wav;\nuse List::Util   qw(min max);\nuse Getopt::Long qw(GetOptions);\n\nmy $max_height = 300;    # resize images larger than this\n\nmy $sample_rate     = 44100;\nmy $bits_sample     = 16;\nmy $frequency_band  = $sample_rate / 2;    # in Hz\nmy $channels        = 1;\nmy $duration_factor = 1;\n\nmy $output_wav = 'output.wav';\n\nsub help ($code) {\n    print <<\"EOT\";\nusage: $0 [options] [images]\n\noptions:\n    -o  --output=s   : output audio file (default: $output_wav)\n    -f  --freq=i     : frequency band in Hz (default: $frequency_band)\n    -d  --duration=f : duration multiplication factor (default: $duration_factor)\n    -b  --bits=i     : bits sample (default: $bits_sample)\n    -s  --sample=i   : sample rate (default: $sample_rate)\n    -c  --channels=i : number of channels (default: $channels)\nEOT\n\n    exit($code);\n}\n\nGetOptions(\n           'o|output=s'          => \\$output_wav,\n           'f|frequency=i'       => \\$frequency_band,\n           'd|duration-factor=f' => \\$duration_factor,\n           'b|bits-sample=i'     => \\$bits_sample,\n           's|sample-rate=i'     => \\$sample_rate,\n           'c|channels=i'        => \\$channels,\n           'h|help'              => sub { help(0) },\n          )\n  or die(\"Error in command line arguments\");\n\nsub range_map ($value, $in_min, $in_max, $out_min, $out_max) {\n    ($value - $in_min) * ($out_max - $out_min) / ($in_max - $in_min) + $out_min;\n}\n\nsub image2spectrogram ($input_file, $write) {\n\n    say \"\\n:: Processing: $input_file\";\n\n    my $img = Imager->new(file => $input_file)\n      or die \"Can't open file <<$input_file>> for reading: $!\";\n\n    my $width  = $img->getwidth;\n    my $height = $img->getheight;\n\n    my $duration = $duration_factor * ($width / $height);\n    say \"-> Duration: $duration seconds\";\n\n    if ($height > $max_height) {\n        $img = $img->scale(ypixels => $max_height, qtype => 'mixing');\n        ($width, $height) = ($img->getwidth, $img->getheight);\n    }\n\n    my $min_size = min($width, $height);\n\n    $width  = int($duration * $min_size);\n    $height = $min_size;\n\n    say \"-> Resizing the image to: $width x $height\";\n    $img = $img->scale(xpixels => $width, ypixels => $height, qtype => 'mixing', type => 'nonprop');\n\n    my @data;\n    my $maxFreq = 0;\n\n    my $numSamples      = int($sample_rate * $duration);\n    my $samplesPerPixel = $numSamples / $width;\n\n    my $C = $frequency_band / $height;\n\n    my @img;\n    foreach my $y (0 .. $height - 1) {\n        my @line = $img->getscanline(y => $y);\n        foreach my $pixel (@line) {\n            my ($R, $G, $B) = $pixel->rgba;\n            ## push @{$img[$y]}, ((($R + $G + $B) / 3) * 100 / 255)**2;\n            ## push @{$img[$y]}, ((0.5 * max($R, $G, $B) + 0.5 * min($R, $G, $B)) * 100 / 255)**2;\n            ## push @{$img[$y]}, (sqrt(0.299 * $R**2 + 0.587 * $G**2 + 0.114 * $B**2) * 100 / 255)**2;\n            push @{$img[$y]}, ((0.299 * $R + 0.587 * $G + 0.114 * $B) * 100 / 255)**2;\n        }\n    }\n\n    say \"-> Converting the pixels to spectrogram frequencies\";\n\n    my $tau = 2 * atan2(0, -1);\n\n    foreach my $x (0 .. $numSamples - 1) {\n\n        my $rez     = 0;\n        my $pixel_x = int($x / $samplesPerPixel);\n\n        foreach my $y (0 .. $height - 1) {\n            my $volume = $img[$y][$pixel_x] || next;\n            my $freq   = sprintf('%.0f', $C * ($height - $y + 1));\n            $rez += sprintf('%.0f', $volume * cos($freq * $tau * $x / $sample_rate));\n        }\n\n        push @data, $rez;\n\n        if (abs($rez) > $maxFreq) {\n            $maxFreq = abs($rez);\n        }\n    }\n\n    say \"-> Maximum frequency: $maxFreq\";\n\n    my $max_no = 2**($bits_sample - 1) - 1;\n\n    #my $min = min(@data);\n    #my $max = max(@data);\n\n    my $min = -$maxFreq;\n    my $max = $maxFreq;\n\n    foreach my $val (@data) {\n        ## $write->write(sprintf('%.0f', $max_no * $val / $maxFreq));\n        $write->write(range_map($val, $min, $max, -$max_no, $max_no));\n    }\n\n    return 1;\n}\n\n@ARGV || help(2);\n\nmy $details = {\n               'bits_sample' => $bits_sample,\n               'sample_rate' => $sample_rate,\n               'channels'    => $channels,\n              };\n\nmy $wav   = Audio::Wav->new;\nmy $write = $wav->write($output_wav, $details);\n\nforeach my $input_img (@ARGV) {\n    image2spectrogram($input_img, $write);\n}\n\n$write->finish();\n"
  },
  {
    "path": "Image/image2digits.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 29 April 2022\n# https://github.com/trizen\n\n# Generate an ASCII representation for an image, using only digits.\n\n# See also:\n#   https://github.com/TotalTechGeek/pictoprime\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse GD qw();\nuse List::Util qw(max);\nuse Getopt::Long qw(GetOptions);\n\nGD::Image->trueColor(1);\n\nmy $size = 80;\n\nsub help {\n    my ($code) = @_;\n    print <<\"HELP\";\nusage: $0 [options] [files]\n\noptions:\n    -w  --width=i : width size of the ASCII image (default: $size)\n\nexample:\n    perl $0 --width 200 image.png\nHELP\n    exit($code);\n}\n\nGetOptions('w|width=s' => \\$size,\n           'h|help'    => sub { help(0) },)\n  or die \"Error in command-line arguments!\";\n\nsub map_value {\n    my ($value, $in_min, $in_max, $out_min, $out_max) = @_;\n    ($value - $in_min) * ($out_max - $out_min) / ($in_max - $in_min) + $out_min;\n}\n\nmy @digits = split(//, \"7772299408\");\n\n#my @digits = 0..9;\n\nsub img2digits {\n    my ($image) = @_;\n\n    my $img = GD::Image->new($image) // return;\n    my ($width, $height) = $img->getBounds;\n\n    if ($size != 0) {\n        my $scale_width  = $size;\n        my $scale_height = int($height / ($width / ($size / 2)));\n\n        my $resized = GD::Image->new($scale_width, $scale_height);\n        $resized->copyResampled($img, 0, 0, 0, 0, $scale_width, $scale_height, $width, $height);\n\n        ($width, $height) = ($scale_width, $scale_height);\n        $img = $resized;\n    }\n\n    my @values;\n\n    foreach my $y (0 .. $height - 1) {\n        foreach my $x (0 .. $width - 1) {\n            my $index = $img->getPixel($x, $y);\n            my ($r, $g, $b) = $img->rgb($index);\n            my $value = max($r, $g, $b);\n            push @values, $digits[map_value($value, 0, 255, 0, $#digits)];\n        }\n    }\n\n    unpack(\"(A$width)*\", join('', @values));\n}\n\nsay for img2digits($ARGV[0] // help(1));\n"
  },
  {
    "path": "Image/image2html.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 15 October 2015\n# Website: https://github.com/trizen\n\n# Generate an HTML representation of an image\n# (best viewed with Firefox)\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse GD qw();\nuse Getopt::Long qw(GetOptions);\nuse HTML::Entities qw(encode_entities);\n\nGD::Image->trueColor(1);\n\nmy $size      = 500;\nmy $font_size = 1;\n\nsub help {\n    my ($code) = @_;\n    print <<\"HELP\";\nusage: $0 [options] [files]\n\noptions:\n    -w  --width=i     : scale the image to this width (default: $size)\n    -f  --font-size=i : HTML font size property (default: $font_size)\n\nexample:\n    perl $0 --width 800 image.png\nHELP\n    exit($code);\n}\n\nGetOptions(\n           'w|width=i'     => \\$size,\n           'f|font-size=f' => \\$font_size,\n           'h|help'        => sub { help(0) },\n          )\n  || die \"Error in command-line arguments!\";\n\nsub img2html {\n    my ($image) = @_;\n\n    my $img = GD::Image->new($image) // return;\n    my ($width, $height) = $img->getBounds;\n\n    if ($size != 0) {\n        my $scale_width = $size;\n        my $scale_height = int($height / ($width / ($size / 2)));\n\n        my $resized = GD::Image->new($scale_width, $scale_height);\n        $resized->copyResampled($img, 0, 0, 0, 0, $scale_width, $scale_height, $width, $height);\n\n        ($width, $height) = ($scale_width, $scale_height);\n        $img = $resized;\n    }\n\n    my @pixels;\n\n    foreach my $y (0 .. $height - 1) {\n        foreach my $x (0 .. $width - 1) {\n            my $index = $img->getPixel($x, $y);\n            push @pixels, [$img->rgb($index)];\n        }\n    }\n\n    my $header = <<\"EOT\";\n<html xmlns=\"https://www.w3.org/1999/xhtml\">\n<head>\n<title>${\\encode_entities($image)}</title>\n<meta http-equiv=\"content-type\" content=\"text/html; charset=utf-8\" />\n<style type=\"text/css\">\n/*<![CDATA[*/\n<!--\n\npre {\n      font-size: $font_size;\n      font-family: monospace;\n    }\n\nEOT\n\n    my $footer = <<'EOT';\n</pre>\n</body>\n</html>\nEOT\n\n    my %colors;\n    my $style = '';\n\n    my @html;\n    my $name = 'A';\n\n    while (@pixels) {\n        push @html, [\n            map {\n                my $color = sprintf(\"%02x%02x%02x\", @{$_});\n\n                if (not exists $colors{$color}) {\n                    $colors{$color} = $name;\n                    $style .= \".$name\\{background-color:#$color;}\\n\";\n                    $name++;\n                }\n\n                $colors{$color};\n              } splice(@pixels, 0, $width)\n        ];\n    }\n\n    my $html = '';\n    foreach my $row (@html) {\n\n        while (@{$row}) {\n            my $class = shift @{$row};\n\n            my $count = 1;\n            while (@{$row} and $row->[0] eq $class) {\n                ++$count;\n                shift @{$row};\n            }\n\n            $html .= qq{<span class=\"$class\">} . (' ' x $count) . \"</span>\";\n        }\n\n        $html .= '<br/>';\n    }\n\n    $style .= <<'EOT';\n-->\n/*]]>*/\n</style>\n</head>\n<body>\n<pre>\nEOT\n\n    join('', $header, $style, $html, $footer);\n}\n\nsay img2html($ARGV[0] // help(1));\n"
  },
  {
    "path": "Image/image2matrix.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 13 August 2016\n# Website: https://github.com/trizen\n\n# Transform an image into a matrix of RGB values.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager;\n\nmy $file = shift(@ARGV) // die \"usage: $0 [image]\";\nmy $img = Imager->new(file => $file);\n\nforeach my $y (0 .. $img->getheight - 1) {\n    say join(\n        ',',\n        map {\n            my $color = $img->getpixel(y => $y, x => $_);\n            my ($r, $g, $b) = $color->rgba;\n\n            my $rgb = $r;\n            $rgb = ($rgb << 8) + $g;\n            $rgb = ($rgb << 8) + $b;\n\n            $rgb\n          } (0 .. $img->getwidth - 1)\n    );\n}\n"
  },
  {
    "path": "Image/image2mozaic.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 13 August 2016\n# Website: https://github.com/trizen\n\n# Transform a regular image into a circle mozaic image.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager;\n\nmy $radius = 4;\nmy $space  = 3;\n\nsub image2mozaic {\n    my ($img, $outfile) = @_;\n\n    my $width  = $img->getwidth;\n    my $height = $img->getheight;\n\n    my $thumb = $img->scale(scalefactor => 1 / ($radius * $space));\n\n    my $thumb_width  = $thumb->getwidth;\n    my $thumb_height = $thumb->getheight;\n\n    my @matrix;\n    foreach my $y (0 .. $thumb_height - 1) {\n        push @matrix, [map {\n                [$thumb->getpixel(y => $y, x => $_)->rgba]\n        } (0 .. $thumb_width - 1)];\n    }\n\n    my $scale_x = int($width / $thumb_width);\n    my $scale_y = int($height / $thumb_height);\n\n    my $mozaic = Imager->new(\n                             xsize    => $scale_x * $thumb_width,\n                             ysize    => $scale_y * $thumb_height,\n                             channels => 3,\n                            );\n\n    my $color = Imager::Color->new(0, 0, 0);\n\n    foreach my $i (0 .. $#matrix) {\n        my $row = $matrix[$i];\n        foreach my $j (0 .. $#{$row}) {\n            $color->set(@{$row->[$j]});\n            $mozaic->circle(\n                            r     => $radius,\n                            x     => int($radius + $j * $scale_x + rand($space)),\n                            y     => int($radius + $i * $scale_y + rand($space)),\n                            color => $color,\n                           );\n        }\n    }\n\n    $mozaic->write(file => $outfile);\n}\n\nmy $file = shift(@ARGV) // die \"usage: $0 [image]\";\nmy $img = Imager->new(file => $file) // die \"can't load image `$file': $!\";\n\nimage2mozaic($img, 'circle_mozaic.png');\n"
  },
  {
    "path": "Image/image2png.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 19 December 2021\n# Edit: 31 July 2022\n# https://github.com/trizen\n\n# Convert any images to PNG, using the Gtk3::Gdk::Pixbuf library.\n\n# It can convert SVG, WEBP, JPEG, and more...\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Gtk3                  qw(-init);\nuse File::Spec::Functions qw(catfile);\nuse File::Basename        qw(dirname basename);\nuse Getopt::Long          qw(GetOptions);\n\nmy %CONFIG = (\n              output_dir   => undef,\n              width        => undef,\n              height       => undef,\n              scale_factor => undef,\n              flipx        => undef,\n              flipy        => undef,\n              remove       => 0,\n             );\n\nsub help ($exit_code = 0) {\n    print <<\"EOT\";\nUsage: $0 [OPTIONS] [<images>]\n\n  -w, --width=WIDTH     Width of output image in pixels\n  -h, --height=HEIGHT   Height of output image in pixels\n  -s, --scale=FACTOR    Scale image by FACTOR\n  -d, --dir=DIRECTORY   Output directory\n\n  --flipx       Flip X coordinates of image\n  --flipy       Flip Y coordinates of image\n\n  --remove!     Remove original files\n  --help        Give this help list\nEOT\n\n    exit($exit_code);\n}\n\nGetOptions(\n           \"d|directory=s\" => \\$CONFIG{output_dir},\n           \"w|width=i\"     => \\$CONFIG{width},\n           \"h|height=i\"    => \\$CONFIG{height},\n           \"s|scale=f\"     => \\$CONFIG{scale_factor},\n           \"flipx\"         => \\$CONFIG{flipx},\n           \"flipy\"         => \\$CONFIG{flipy},\n           \"remove!\"       => \\$CONFIG{remove},\n           'help'          => sub { help(0) },\n          )\n  or help(1);\n\n@ARGV || help(2);\n\nsub image2png ($input_file, $output_file = undef) {\n\n    my $pixbuf;\n\n    if (defined($CONFIG{width}) or defined($CONFIG{height})) {\n\n        my $width = $CONFIG{width} // do {\n            my (undef, $x, $y) = Gtk3::Gdk::Pixbuf::get_file_info($input_file);\n            int($x / ($y / $CONFIG{height}));\n        };\n\n        my $height            = $CONFIG{height} // $CONFIG{width};\n        my $keep_aspect_ratio = ($CONFIG{width} && $CONFIG{height}) ? 0 : 1;\n\n        $pixbuf = \"Gtk3::Gdk::Pixbuf\"->new_from_file_at_scale($input_file, $width, $height, $keep_aspect_ratio);\n    }\n    elsif (defined($CONFIG{scale_factor})) {\n        my (undef, $width, $height) = Gtk3::Gdk::Pixbuf::get_file_info($input_file);\n        my $scale = $CONFIG{scale_factor};\n        $pixbuf = \"Gtk3::Gdk::Pixbuf\"->new_from_file_at_scale($input_file, $width * $scale, $height * $scale, 0);\n    }\n    else {\n        $pixbuf = \"Gtk3::Gdk::Pixbuf\"->new_from_file($input_file);\n    }\n\n    if ($CONFIG{flipx}) {\n        $pixbuf = $pixbuf->flip(1);\n    }\n\n    if ($CONFIG{flipy}) {\n        $pixbuf = $pixbuf->flip(0);\n    }\n\n    if (defined($pixbuf)) {\n        if (!defined($output_file)) {\n\n            my $output_dir = $CONFIG{output_dir} // dirname($input_file);\n            my $basename   = basename($input_file);\n\n            if (not $basename =~ s/\\.(svg|jpe?g|webp|gif|avif|jfif|pjpeg|pjp|bmp|ico|tiff?|xpm)\\z/.png/i) {\n                $basename .= '.png';\n            }\n\n            if (not -d $output_dir) {\n                require File::Path;\n                File::Path::make_path($output_dir)\n                  || warn \"Cannot create output directory <<$output_dir>>: $!\\n\";\n            }\n\n            $output_file = catfile($output_dir, $basename);\n        }\n        $pixbuf->save($output_file, 'png');\n        return 1;\n    }\n\n    return undef;\n}\n\nforeach my $file (@ARGV) {\n    say \":: Processing: $file\";\n    if (-e $file) {\n        if (image2png($file)) {\n            if ($CONFIG{remove}) {\n                say \":: Removing original file...\";\n                unlink($file) or warn \"Cannot remove file <<$file>>: $!\\n\";\n            }\n        }\n        else {\n            warn \"Cannot convert file <<$file>>! Skipping...\\n\";\n        }\n    }\n    else {\n        warn \"File <<$file>> does not exist! Skipping...\\n\";\n    }\n}\n"
  },
  {
    "path": "Image/image2prime.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 29 April 2022\n# https://github.com/trizen\n\n# Generate an ASCII representation for an image, using only digits, such that the number is a prime.\n\n# Inspired by the following Matt Parker video:\n#   https://yewtu.be/watch?v=dET2l8l3upU\n\n# See also:\n#   https://github.com/TotalTechGeek/pictoprime\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse GD qw();\nuse List::Util qw(max);\nuse Getopt::Long qw(GetOptions);\nuse Math::Prime::Util::GMP qw(is_prob_prime);\n\nuse constant {\n              GENERATE_PRIME => 1,    # true to generate primes (slow)\n             };\n\nGD::Image->trueColor(1);\n\nmy $size = 80;\n\nsub help {\n    my ($code) = @_;\n    print <<\"HELP\";\nusage: $0 [options] [files]\n\noptions:\n    -w  --width=i : width size of the ASCII image (default: $size)\n\nexample:\n    perl $0 --width 200 image.png\nHELP\n    exit($code);\n}\n\nGetOptions('w|width=s' => \\$size,\n           'h|help'    => sub { help(0) },)\n  or die \"Error in command-line arguments!\";\n\nsub map_value {\n    my ($value, $in_min, $in_max, $out_min, $out_max) = @_;\n    ($value - $in_min) * ($out_max - $out_min) / ($in_max - $in_min) + $out_min;\n}\n\nmy @digits = split(//, \"7772299408\");\n\n#my @digits = 0..9;\n\n# The ways that we allow the algorithm to substitute a character.\n# Like 0 can become 8 or 9, so on and so forth.\nmy %substitutions = (\n    '0' => ['8', '9'],\n    '1' => ['7'],\n    '7' => ['1'],\n    '8' => ['0', '9'],\n    '9' => ['4'],\n    '4' => ['9'],\n                    );\n\n# These are used to swap out the last digit if necessary.\nmy %edge_digit_substitutions = (\n                                '0' => '3',\n                                '2' => '3',\n                                '4' => '9',\n                                '6' => '9',\n                                '8' => '9',\n                                '5' => '3'\n                               );\n\nsub create_prime {\n    my ($pixels) = @_;\n\n    GENERATE_PRIME || return $pixels;\n\n    if (substr($pixels, 0, 1) == 0) {\n        substr($pixels, 0, 1, $edge_digit_substitutions{0});\n    }\n\n    if (exists($edge_digit_substitutions{substr($pixels, -1)})) {\n        my $digit = chop $pixels;\n        $pixels .= $edge_digit_substitutions{$digit};\n    }\n\n    my $count  = 0;\n    my $copy   = $pixels;\n    my $length = length($pixels);\n\n    my @substitution_indices = grep { exists $substitutions{substr($pixels, $_, 1)} } 0 .. $length - 1;\n\n    while (1) {\n\n        if (is_prob_prime($pixels)) {\n            return $pixels;\n        }\n\n        if (++$count > 5) {\n            $pixels = $copy;\n            $count  = 0;\n        }\n\n        my $rand  = $substitution_indices[int rand scalar @substitution_indices];\n        my $digit = substr($pixels, $rand, 1);\n        my $alt   = $substitutions{$digit};\n\n        substr($pixels, $rand, 1, $alt->[int rand scalar @$alt]);\n    }\n}\n\nsub img2prime {\n    my ($image) = @_;\n\n    my $img = GD::Image->new($image) // return;\n    my ($width, $height) = $img->getBounds;\n\n    if ($size != 0) {\n        my $scale_width  = $size;\n        my $scale_height = int($height / ($width / ($size / 2)));\n\n        my $resized = GD::Image->new($scale_width, $scale_height);\n        $resized->copyResampled($img, 0, 0, 0, 0, $scale_width, $scale_height, $width, $height);\n\n        ($width, $height) = ($scale_width, $scale_height);\n        $img = $resized;\n    }\n\n    my $avg = 0;\n    my @averages;\n\n    foreach my $y (0 .. $height - 1) {\n        foreach my $x (0 .. $width - 1) {\n            my $index = $img->getPixel($x, $y);\n            my ($r, $g, $b) = $img->rgb($index);\n            my $value = max($r, $g, $b);\n            push @averages, $digits[map_value($value, 0, 255, 0, $#digits)];\n        }\n    }\n\n    my $prime = create_prime(join('', @averages));\n    unpack(\"(A$width)*\", $prime);\n}\n\nsay for img2prime($ARGV[0] // help(1));\n\n__END__\n30000000000000000000000000000000000000000000000000000000000000000000000000000000\n00000000000000000000000000000000000000000000000000000000000000000000000000000000\n00000000000000000000000000000000000000000000000000000000000000000000000000000000\n00000000000000000000000000000000000000000000000000000000000000000000000000000000\n00000000000000000000000000000000000000000000000000000000000000000000000000000000\n00000000000000000000001002222333222221100000000000000000000000000000000000000000\n00000000000000000001101343344444444333332211000000000000000000000000000000000000\n00000000000000000000355455555555556666666665544332100000000000000000000000000000\n00000000000000003543245666666666777777777666665544321000000000000000000000000000\n00000000000000001256666666677777777777777776666655432100000000000000000000000000\n00000000011144433225666678888888876555556655543433322100000000000000000000000000\n00000000012234667777767888888753135554300134310000000000000000000000000000000000\n00000000001233356777888888884013366653000000000000000000000110000000000000000000\n00000000000013345678888888711335667631000000000000000000000000010000000000000000\n00001124556666656888888888123456776520000000000000111111100000011110000000000000\n00033334567777788888888885245667776651000000000010000000000000001110001000000000\n00021034355667788888888884456778877766520000000100000000022000000100000100000000\n00000013044455888888888887788888888875300000000110000000132032111000000110000000\n00000000012053888888888888888888888888400000000111001110220301211000001110000000\n00000000000020788888888888888888888888830000001000000022021013133211001100000000\n00000000000020788888888888888888888888830000010000000001221121121011000001000000\n00000000013054888888888888888888888888400000001000001222222122231000000001000000\n00000013044455888888888887778888888885400000000001100000001221021000000010000000\n00022034355677788888888884456668877766420000000001110000011000000001111000000000\n00033335567777788888888885235667776651000000000000100000000000000001100000000000\n00000124455666655888888888123456777520000800000000011000011110000011000000000000\n00000000000023345678888888711334667641000000000000000110000011111100000000000000\n00000000001233356777888888884113366653000000000000000000000000000000000000000000\n00000000012234667777767888888753135554300134310000000000000000000000000000000000\n00000000011134332225666678888888876555556655544433332100000000000000000000000000\n00000000000000001256666666667777777777777776666655432100000000000000000000000000\n00000000000000013443245666666666777777777666665544321000000000000000000000000000\n00000000000000000000354455555555555666665555543321100000000000000000000000000000\n00000000000000000001101343344344434343332210000000000000000000000000000000000000\n00000000000000000000001002222223222221100000000000000000000000000000000000000000\n00000000000000000000000000000000000000000000000000000000000000000000000000000000\n00000000000000000000000000000000000000000000000000000000000000000000000000000000\n00000000000000000000000000000000000000000000000000000000000000000000000000000000\n00000000000000000000000000000000000000000000000000000000000000000000000000000000\n00000000000000000000000000000000000000000000000000000000000000000000000000000003\n"
  },
  {
    "path": "Image/image_metadata_clone.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 26 September 2025\n# https://github.com/trizen\n\n# Copy EXIF metadata from images, given a source directory and a destination directory.\n\n# Metadata from each image from the source directory is added to the images\n# in the destination directory, based on the filename of each image.\n\nuse 5.036;\nuse Image::ExifTool qw();\nuse File::Find      qw(find);\nuse File::Basename  qw(basename);\nuse Getopt::Long    qw(GetOptions);\n\nmy $img_formats = '';\n\nmy @img_formats = qw(\n  jpeg\n  jpg\n);\n\nsub usage($exit_code = 0) {\n\n    print <<\"EOT\";\nusage: $0 [options] [source dir] [dest dir]\n\noptions:\n    -f  --formats=s,s   : specify more image formats (default: @img_formats)\n    --help              : print this message and exit\nEOT\n\n    exit $exit_code;\n}\n\nGetOptions(\"f|formats=s\" => \\$img_formats,\n           'help'        => sub { usage(0) })\n  or die(\"Error in command line arguments\\n\");\n\n@ARGV == 2 or usage(1);\n\nsub add_exif_info($source_image, $dest_image) {\n\n    my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks) = stat($dest_image);\n\n    my $exifTool  = Image::ExifTool->new;\n    my $exif_info = $exifTool->SetNewValuesFromFile($source_image);\n\n    $exifTool = Image::ExifTool->new;\n\n    foreach my $key (keys %$exif_info) {\n        my $value = $exif_info->{$key};\n        $exifTool->SetNewValue($key, $value);\n    }\n\n    $exifTool->WriteInfo($dest_image);\n\n    # Set the original modification time\n    utime($atime, $mtime, $dest_image)\n      or warn \"Can't change timestamp: $!\\n\";\n\n    # Set original permissions\n    chmod($mode & 07777, $dest_image)\n      or warn \"Can't change permissions: $!\\n\";\n\n    # Set the original ownership of the image\n    chown($uid, $gid, $dest_image);\n}\n\npush @img_formats, map { quotemeta } split(/\\s*,\\s*/, $img_formats);\n\nmy $img_formats_re = do {\n    local $\" = '|';\n    qr/\\.(@img_formats)\\z/i;\n};\n\nmy ($source_dir, $dest_dir) = @ARGV;\n\nmy %source_files;\n\nfind {\n    no_chdir => 1,\n    wanted   => sub {\n        (/$img_formats_re/o && -f) || return;\n        my $basename = basename($_);\n        $source_files{$basename} = $_;\n    }\n} => $source_dir;\n\nfind {\n    no_chdir => 1,\n    wanted   => sub {\n        (/$img_formats_re/o && -f) || return;\n\n        my $basename = basename($_);\n\n        if (exists($source_files{$basename})) {\n            say \"Adding EXIF metadata to: $_\";\n            add_exif_info($source_files{$basename}, $_);\n        }\n        else {\n            warn \"Couldn't find <<$basename>> into source directory. Skipping...\\n\";\n        }\n    }\n} => $dest_dir;\n"
  },
  {
    "path": "Image/imager_similar_images.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 26 August 2015\n# Edit: 24 October 2023\n# Website: https://github.com/trizen\n\n# Find images that look similar.\n\n# Blog post:\n#   https://trizenx.blogspot.com/2015/08/finding-similar-images.html\n\nuse 5.022;\nuse strict;\nuse warnings;\n\nuse experimental qw(bitwise);\n\nuse Imager       qw();\nuse List::Util   qw(sum);\nuse File::Find   qw(find);\nuse Getopt::Long qw(GetOptions);\n\nmy $width      = 32;\nmy $height     = 'auto';\nmy $percentage = 90;\n\nmy $keep_only   = undef;\nmy $img_formats = '';\n\nmy @img_formats = qw(\n  jpeg\n  jpg\n  png\n);\n\nsub help {\n    my ($code) = @_;\n    local $\" = \",\";\n    print <<\"EOT\";\nusage: $0 [options] [dir]\n\noptions:\n    -p  --percentage=i  : minimum similarity percentage (default: $percentage)\n    -w  --width=i       : resize images to this width (default: $width)\n    -h  --height=i      : resize images to this height (default: $height)\n    -f  --formats=s,s   : specify more image formats (default: @img_formats)\n    -k  --keep=s        : keep only the 'smallest' or 'largest' image from each group\n\nWARNING: option '-k' permanently removes your images!\n\nexample:\n    perl $0 -p 75 -r '8x8' ~/Pictures\nEOT\n\n    exit($code);\n}\n\nGetOptions(\n           'p|percentage=i' => \\$percentage,\n           'w|width=s'      => \\$width,\n           'h|height=s'     => \\$height,\n           'f|formats=s'    => \\$img_formats,\n           'k|keep=s'       => \\$keep_only,\n          )\n  or die(\"Error in command line arguments\");\n\npush @img_formats, map { quotemeta } split(/\\s*,\\s*/, $img_formats);\n\nmy $img_formats_re = do {\n    local $\" = '|';\n    qr/\\.(@img_formats)\\z/i;\n};\n\n#<<<\nsub alike_percentage {\n    ((($_[0] ^. $_[1]) =~ tr/\\0//) / $_[2])**2 * 100;\n}\n#>>>\n\nsub fingerprint {\n    my ($image) = @_;\n\n    my $img = Imager->new(file => $image) or do {\n        warn \"Failed to load <<$image>>: \", Imager->errstr();\n        return;\n    };\n\n    if ($height ne 'auto') {\n        $img = $img->scale(ypixels => $height, qtype => 'preview');\n    }\n    else {\n        $img = $img->scale(xpixels => $width, qtype => 'preview');\n    }\n\n    my ($curr_width, $curr_height) = ($img->getwidth, $img->getheight);\n\n    my @averages;\n    foreach my $y (0 .. $curr_height - 1) {\n        my @line = $img->getscanline(y => $y);\n        foreach my $pixel (@line) {\n            my ($R, $G, $B) = $pixel->rgba;\n            push @averages, sum($R, $G, $B) / 3;\n        }\n    }\n\n    my $avg = sum(@averages) / @averages;\n    [join('', map { ($_ < $avg) ? 1 : 0 } @averages), $curr_width, $curr_height];\n}\n\nsub find_similar_images(&@) {\n    my $callback = shift;\n\n    my @files;\n    find {\n        no_chdir => 1,\n        wanted   => sub {\n            (/$img_formats_re/o && -f) || return;\n\n            push @files,\n              {\n                fingerprint => fingerprint($_) // return,\n                filename    => $_,\n              };\n        }\n    } => @_;\n\n    #\n    ## Populate the %alike hash\n    #\n    my %alike;\n    foreach my $i (0 .. $#files - 1) {\n        for (my $j = $i + 1 ; $j <= $#files ; $j++) {\n            my $p = alike_percentage(\n                           $files[$i]{fingerprint}->[0],\n                           $files[$j]{fingerprint}->[0],\n                           sqrt($files[$i]{fingerprint}->[1] * $files[$j]{fingerprint}->[1]) * sqrt($files[$i]{fingerprint}->[2] * $files[$j]{fingerprint}->[2])\n            );\n            if ($p >= $percentage) {\n                $alike{$files[$i]{filename}}{$files[$j]{filename}} = $p;\n                $alike{$files[$j]{filename}}{$files[$i]{filename}} = $p;\n            }\n        }\n    }\n\n    #\n    ## Group the files\n    #\n    my @alike;\n    foreach my $root (\n        map  { $_->[0] }\n        sort { ($a->[1] <=> $b->[1]) || ($b->[2] <=> $a->[2]) }\n        map {\n            my $keys = keys(%{$alike{$_}});\n            my $avg  = sum(values(%{$alike{$_}})) / $keys;\n\n            [$_, $keys, $avg]\n        }\n        keys %alike\n      ) {\n        my @group = keys(%{$alike{$root}});\n        if (@group) {\n            my $avg = 0;\n            $avg += delete($alike{$_}{$root}) for @group;\n            push @alike, {score => $avg / @group, files => [$root, @group]};\n\n        }\n    }\n\n    #\n    ## Callback each group\n    #\n    my %seen;\n    foreach my $group (sort { $b->{score} <=> $a->{score} } @alike) {\n        (@{$group->{files}} == grep { $seen{$_}++ } @{$group->{files}}) and next;\n        $callback->($group->{score}, $group->{files});\n    }\n\n    return 1;\n}\n\n@ARGV || help(1);\nfind_similar_images {\n    my ($score, $files) = @_;\n\n    printf(\"=> Similarity: %.0f%%\\n\", $score);\n    say join(\"\\n\", sort @{$files});\n    say \"-\" x 80;\n\n    if (defined($keep_only)) {\n\n        my @existent_files = grep { -f $_ } @$files;\n\n        scalar(@existent_files) > 1 or return;\n\n        my @sorted_by_size = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [$_, -s $_] } @existent_files;\n        if ($keep_only =~ /large/i) {\n            pop(@sorted_by_size);\n        }\n        elsif ($keep_only =~ /small/i) {\n            shift(@sorted_by_size);\n        }\n        else {\n            die \"error: unknown value <<$keep_only>> for option `-k`!\\n\";\n        }\n        foreach my $file (@sorted_by_size) {\n            say \"Removing: $file\";\n            unlink($file) or warn \"Failed to remove: $!\";\n        }\n    }\n} @ARGV;\n"
  },
  {
    "path": "Image/img-autocrop-avg.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 14 June 2015\n# Edit: 19 March 2017\n# https://github.com/trizen\n\n# A generic image auto-cropper which adapt itself to any background color.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse GD qw();\n\nuse Getopt::Long qw(GetOptions);\nuse File::Basename qw(basename);\nuse File::Spec::Functions qw(catfile);\n\n# Set true color\nGD::Image->trueColor(1);\n\n# Autoflush mode\nlocal $| = 1;\n\nmy $tolerance = 5;\nmy $invisible = 0;\n\nmy $jpeg_quality    = 95;\nmy $png_compression = 7;\n\nmy $directory = 'Cropped images';\n\nsub help {\n    my ($code) = @_;\n    print <<\"EOT\";\nusage: $0 [options] [images]\n\noptions:\n    -t --tolerance=i    : tolerance value for the background color\n                          default: $tolerance\n\n    -i --invisible!     : make the background transparent after cropping\n                          default: ${$invisible ? \\'true' : \\'false'}\n\n    -p --png-compress=i : the compression level for PNG images\n                          default: $png_compression\n\n    -j --jpeg-quality=i : the quality value for JPEG images\n                          default: $jpeg_quality\n\n    -d --directory=s    : directory where to create the cropped images\n                          default: \"$directory\"\n\nexample:\n    perl $0 -t 10 *.png\nEOT\n    exit($code // 0);\n}\n\nGetOptions(\n           'd|directory=s'       => \\$directory,\n           'i|invisible!'        => \\$invisible,\n           't|tolerance=i'       => \\$tolerance,\n           'p|png-compression=i' => \\$png_compression,\n           'j|jpeg-quality=i'    => \\$jpeg_quality,\n           'h|help'              => sub { help(0) },\n          )\n  or die(\"$0: error in command line arguments!\\n\");\n\n{\n    my %cache;\n\n    sub is_background {\n        my ($img, $index, $bg_rgb) = @_;\n        my $rgb = ($cache{$index} //= [$img->rgb($index)]);\n        abs($rgb->[0] - $bg_rgb->[0]) <= $tolerance\n          and abs($rgb->[1] - $bg_rgb->[1]) <= $tolerance\n          and abs($rgb->[2] - $bg_rgb->[2]) <= $tolerance;\n    }\n}\n\nsub make_invisible_bg {\n    my ($img, $transparent, $bg_rgb, $width, $height) = @_;\n\n    foreach my $x (0 .. $width) {\n        foreach my $y (0 .. $height) {\n            if (is_background($img, $img->getPixel($x, $y), $bg_rgb)) {\n                $img->setPixel($x, $y, $transparent);\n            }\n        }\n    }\n}\n\nsub autocrop {\n    my @images = @_;\n\n    foreach my $file (@images) {\n        my $img = GD::Image->new($file);\n\n        if (not defined $img) {\n            warn \"[!] Can't process image `$file': $!\\n\";\n            next;\n        }\n\n        my ($width, $height) = $img->getBounds();\n\n        $width  -= 1;\n        $height -= 1;\n\n        my $C = (2 * $width + 1 + 2 * $height + 1);\n        my @bg_rgb = (0, 0, 0);\n\n        foreach my $x (0 .. $width) {\n            for my $arr ([map { $_ / $C } $img->rgb($img->getPixel($x, 0))],\n                         [map { $_ / $C } $img->rgb($img->getPixel($x, $height))]) {\n                $bg_rgb[0] += $arr->[0];\n                $bg_rgb[1] += $arr->[1];\n                $bg_rgb[2] += $arr->[2];\n            }\n        }\n\n        foreach my $y (0 .. $height) {\n            for my $arr ([map { $_ / $C } $img->rgb($img->getPixel(0, $y))],\n                         [map { $_ / $C } $img->rgb($img->getPixel($width, $y))]) {\n                $bg_rgb[0] += $arr->[0];\n                $bg_rgb[1] += $arr->[1];\n                $bg_rgb[2] += $arr->[2];\n            }\n        }\n\n        print \"Cropping: $file\";\n\n        my $top;\n        my $bottom;\n      TB: foreach my $y (1 .. $height) {\n            foreach my $x (1 .. $width) {\n\n                if (not defined $top) {\n                    if (not is_background($img, $img->getPixel($x, $y), \\@bg_rgb)) {\n                        $top = $y - 1;\n                    }\n                }\n\n                if (not defined $bottom) {\n                    if (not is_background($img, $img->getPixel($x, $height - $y), \\@bg_rgb)) {\n                        $bottom = $height - $y + 1;\n                    }\n                }\n\n                if (defined $top and defined $bottom) {\n                    last TB;\n                }\n            }\n        }\n\n        if (not defined $top or not defined $bottom) {\n            say \" - fail!\";\n            next;\n        }\n\n        my $left;\n        my $right;\n      LR: foreach my $x (1 .. $width) {\n            foreach my $y (1 .. $height) {\n                if (not defined $left) {\n                    if (not is_background($img, $img->getPixel($x, $y), \\@bg_rgb)) {\n                        $left = $x - 1;\n                    }\n                }\n\n                if (not defined $right) {\n                    if (not is_background($img, $img->getPixel($width - $x, $y), \\@bg_rgb)) {\n                        $right = $width - $x + 1;\n                    }\n                }\n\n                if (defined $left and defined $right) {\n                    last LR;\n                }\n            }\n        }\n\n        if (not defined $left or not defined $right) {\n            say \" - fail!\";\n            next;\n        }\n\n        my $cropped = GD::Image->new($right - $left + 1, $bottom - $top + 1);\n\n        my $index;\n        if ($invisible) {\n            $index = $cropped->colorAllocateAlpha(int(rand(256)), int(rand(256)), int(rand(256)), 0);\n            $cropped->filledRectangle(0, 0, $cropped->width, $cropped->height, $index);\n            $cropped->transparent($index);\n        }\n\n        $cropped->copyResized(\n                              $img,\n                              0,          # destX\n                              0,          # destY\n                              $left,      # srcX\n                              $top,       # srcY\n                              $right,     # destW\n                              $bottom,    # destH\n                              $right,     # srcW\n                              $bottom,    # srcH\n                             );\n\n        my $name = catfile($directory, basename($file));\n\n        if ($invisible) {\n            make_invisible_bg($cropped, $index, \\@bg_rgb, $cropped->width - 1, $cropped->height - 1);\n            $name =~ s/\\.\\w+\\z/.png/;\n        }\n\n        open my $fh, '>:raw', $name or die \"Can't create file `$name': $!\";\n        print $fh (\n                     $name =~ /\\.png\\z/i ? $cropped->png($png_compression)\n                   : $name =~ /\\.gif\\z/i ? $cropped->gif\n                   :                       $cropped->jpeg($jpeg_quality)\n                  );\n        close $fh;\n\n        say \" - ok!\";\n    }\n}\n\n@ARGV || help(1);\n\nif (not -d $directory) {\n    mkdir($directory) || die \"Can't mkdir `$directory': $!\";\n}\n\nautocrop(@ARGV);\n"
  },
  {
    "path": "Image/img-autocrop-whitebg.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 14 June 2015\n# https://github.com/trizen\n\n# Auto-crop a list of images that have a white background.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse GD qw();\n\nuse File::Basename qw(basename);\nuse File::Spec::Functions qw(catfile);\n\n# Set true color\nGD::Image->trueColor(1);\n\n# Autoflush mode\nlocal $| = 1;\n\nmy $dir = 'Cropped images';\n\nsub check {\n    my ($img, $width, $height) = @_;\n\n    my $check = sub {\n        foreach my $sub (@_) {\n            $sub->() == 0 or return;\n        }\n        1;\n    };\n\n    my $w_lt_h = $width < $height;\n    my $min = $w_lt_h ? $width : $height;\n\n    my %seen;\n\n    # Spiral in to smaller gaps\n    # -- this algorithm needs to be improved --\n    for (my $i = int(sqrt($min)) ; $i >= 1 ; $i--) {\n        foreach my $j (1 .. $min) {\n\n            next if $j % $i;\n            next if $seen{$j}++;\n\n            if (\n                not $check->(\n                             sub { $img->getPixel($j,     0) },\n                             sub { $img->getPixel(0,      $j) },\n                             sub { $img->getPixel($j,     $height) },\n                             sub { $img->getPixel($width, $j) },\n                            )\n              ) {\n                return;\n            }\n        }\n    }\n\n    if ($w_lt_h) {\n        foreach my $y ($width + 1 .. $height) {\n            if (not $check->(sub { $img->getPixel(0, $y) }, sub { $img->getPixel($width, $y) })) {\n                return;\n            }\n        }\n    }\n    else {\n        foreach my $x ($height + 1 .. $width) {\n            if (not $check->(sub { $img->getPixel($x, 0) }, sub { $img->getPixel($x, $height) })) {\n                return;\n            }\n        }\n    }\n\n    return 1;\n}\n\nsub autocrop {\n    my @images = @_;\n\n    foreach my $file (@images) {\n        my $img = GD::Image->new($file);\n\n        if (not defined $img) {\n            warn \"[!] Can't process image `$file': $!\\n\";\n            next;\n        }\n\n        my ($width, $height) = $img->getBounds();\n\n        $width  -= 1;\n        $height -= 1;\n\n        print \"Checking: $file\";\n        check($img, $width, $height) || do {\n            print \" - fail!\\n\";\n            next;\n        };\n\n        print \" - ok!\\n\";\n        print \"Cropping: $file\";\n\n        my $top;\n        my $bottom;\n      TB: foreach my $y (1 .. $height) {\n            foreach my $x (1 .. $width) {\n\n                if (not defined $top) {\n                    if ($img->getPixel($x, $y)) {\n                        $top = $y - 1;\n                    }\n                }\n\n                if (not defined $bottom) {\n                    if ($img->getPixel($x, $height - $y)) {\n                        $bottom = $height - $y + 1;\n                    }\n                }\n\n                if (defined $top and defined $bottom) {\n                    last TB;\n                }\n            }\n        }\n\n        my $left;\n        my $right;\n      LR: foreach my $x (1 .. $width) {\n            foreach my $y (1 .. $height) {\n                if (not defined $left) {\n                    if ($img->getPixel($x, $y)) {\n                        $left = $x - 1;\n                    }\n                }\n\n                if (not defined $right) {\n                    if ($img->getPixel($width - $x, $y)) {\n                        $right = $width - $x + 1;\n                    }\n                }\n\n                if (defined $left and defined $right) {\n                    last LR;\n                }\n            }\n        }\n\n        my $cropped = GD::Image->new($right - $left + 1, $bottom - $top + 1);\n        $cropped->copyResized(\n                              $img,\n                              0,          # destX\n                              0,          # destY\n                              $left,      # srcX\n                              $top,       # srcY\n                              $right,     # destW\n                              $bottom,    # destH\n                              $right,     # srcW\n                              $bottom,    # srcH\n                             );\n\n        my $name = catfile($dir, basename($file));\n\n        open my $fh, '>:raw', $name or die \"Can't create file `$name': $!\";\n        print $fh ($name =~ /\\.png\\z/i ? $cropped->png : $cropped->jpeg);\n        close $fh;\n\n        print \" - ok!\\n\";\n    }\n}\n\n@ARGV || die \"usage: $0 [images]\\n\";\n\nif (not -d $dir) {\n    mkdir($dir) || die \"Can't mkdir `$dir': $!\";\n}\n\nautocrop(@ARGV);\n"
  },
  {
    "path": "Image/img-autocrop.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 14 June 2015\n# https://github.com/trizen\n\n# A generic image auto-cropper which adapt itself to any background color.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse GD qw();\n\nuse Getopt::Long qw(GetOptions);\nuse File::Basename qw(basename);\nuse File::Spec::Functions qw(catfile);\n\n# Set true color\nGD::Image->trueColor(1);\n\n# Autoflush mode\nlocal $| = 1;\n\nmy $tolerance = 5;\nmy $invisible = 0;\n\nmy $jpeg_quality    = 95;\nmy $png_compression = 7;\n\nmy $directory = 'Cropped images';\n\nsub help {\n    my ($code) = @_;\n    print <<\"EOT\";\nusage: $0 [options] [images]\n\noptions:\n    -t --tolerance=i    : tolerance value for the background color\n                          default: $tolerance\n\n    -i --invisible!     : make the background transparent after cropping\n                          default: ${$invisible ? \\'true' : \\'false'}\n\n    -p --png-compress=i : the compression level for PNG images\n                          default: $png_compression\n\n    -j --jpeg-quality=i : the quality value for JPEG images\n                          default: $jpeg_quality\n\n    -d --directory=s    : directory where to create the cropped images\n                          default: \"$directory\"\n\nexample:\n    perl $0 -t 10 *.png\nEOT\n    exit($code // 0);\n}\n\nGetOptions(\n           'd|directory=s'       => \\$directory,\n           'i|invisible!'        => \\$invisible,\n           't|tolerance=i'       => \\$tolerance,\n           'p|png-compression=i' => \\$png_compression,\n           'j|jpeg-quality=i'    => \\$jpeg_quality,\n           'h|help'              => sub { help(0) },\n          )\n  or die(\"$0: error in command line arguments!\\n\");\n\n{\n    my %cache;\n\n    sub is_background {\n        my ($img, $index, $bg_rgb) = @_;\n        my $rgb = ($cache{$index} //= [$img->rgb($index)]);\n        abs($rgb->[0] - $bg_rgb->[0]) <= $tolerance\n          and abs($rgb->[1] - $bg_rgb->[1]) <= $tolerance\n          and abs($rgb->[2] - $bg_rgb->[2]) <= $tolerance;\n    }\n}\n\nsub check {\n    my ($img, $bg_rgb, $width, $height) = @_;\n\n    my $check = sub {\n        foreach my $sub (@_) {\n            is_background($img, $sub->(), $bg_rgb) || return;\n        }\n        1;\n    };\n\n    my $w_lt_h = $width < $height;\n    my $min = $w_lt_h ? $width : $height;\n\n    my %seen;\n\n    # Spiral-in to smaller gaps\n    # -- this algorithm needs to be improved --\n    for (my $i = int(sqrt($min)) ; $i >= 1 ; $i--) {\n        foreach my $j (1 .. $min) {\n\n            next if $j % $i;\n            next if $seen{$j}++;\n\n            if (\n                not $check->(\n                             sub { $img->getPixel($j,     0) },\n                             sub { $img->getPixel(0,      $j) },\n                             sub { $img->getPixel($j,     $height) },\n                             sub { $img->getPixel($width, $j) },\n                            )\n              ) {\n                return;\n            }\n        }\n    }\n\n    if ($w_lt_h) {\n        foreach my $y ($width + 1 .. $height) {\n            if (not $check->(sub { $img->getPixel(0, $y) }, sub { $img->getPixel($width, $y) })) {\n                return;\n            }\n        }\n    }\n    else {\n        foreach my $x ($height + 1 .. $width) {\n            if (not $check->(sub { $img->getPixel($x, 0) }, sub { $img->getPixel($x, $height) })) {\n                return;\n            }\n        }\n    }\n\n    return 1;\n}\n\nsub make_invisible_bg {\n    my ($img, $transparent, $bg_rgb, $width, $height) = @_;\n\n    foreach my $x (0 .. $width) {\n        foreach my $y (0 .. $height) {\n            if (is_background($img, $img->getPixel($x, $y), $bg_rgb)) {\n                $img->setPixel($x, $y, $transparent);\n            }\n        }\n    }\n}\n\nsub autocrop {\n    my @images = @_;\n\n    foreach my $file (@images) {\n        my $img = GD::Image->new($file);\n\n        if (not defined $img) {\n            warn \"[!] Can't process image `$file': $!\\n\";\n            next;\n        }\n\n        my ($width, $height) = $img->getBounds();\n\n        $width  -= 1;\n        $height -= 1;\n\n        my $bg_rgb = [$img->rgb($img->getPixel(0, 0))];\n\n        print \"Checking: $file\";\n        check($img, $bg_rgb, $width, $height) || do {\n            say \" - fail!\";\n            next;\n        };\n\n        say \" - ok!\";\n        print \"Cropping: $file\";\n\n        my $top;\n        my $bottom;\n      TB: foreach my $y (1 .. $height) {\n            foreach my $x (1 .. $width) {\n\n                if (not defined $top) {\n                    if (not is_background($img, $img->getPixel($x, $y), $bg_rgb)) {\n                        $top = $y - 1;\n                    }\n                }\n\n                if (not defined $bottom) {\n                    if (not is_background($img, $img->getPixel($x, $height - $y), $bg_rgb)) {\n                        $bottom = $height - $y + 1;\n                    }\n                }\n\n                if (defined $top and defined $bottom) {\n                    last TB;\n                }\n            }\n        }\n\n        if (not defined $top or not defined $bottom) {\n            say \" - fail!\";\n            next;\n        }\n\n        my $left;\n        my $right;\n      LR: foreach my $x (1 .. $width) {\n            foreach my $y (1 .. $height) {\n                if (not defined $left) {\n                    if (not is_background($img, $img->getPixel($x, $y), $bg_rgb)) {\n                        $left = $x - 1;\n                    }\n                }\n\n                if (not defined $right) {\n                    if (not is_background($img, $img->getPixel($width - $x, $y), $bg_rgb)) {\n                        $right = $width - $x + 1;\n                    }\n                }\n\n                if (defined $left and defined $right) {\n                    last LR;\n                }\n            }\n        }\n\n        if (not defined $left or not defined $right) {\n            say \" - fail!\";\n            next;\n        }\n\n        my $cropped = GD::Image->new($right - $left + 1, $bottom - $top + 1);\n\n        my $index;\n        if ($invisible) {\n            $index = $cropped->colorAllocateAlpha(int(rand(256)), int(rand(256)), int(rand(256)), 0);\n            $cropped->filledRectangle(0, 0, $cropped->width, $cropped->height, $index);\n            $cropped->transparent($index);\n        }\n\n        $cropped->copyResized(\n                              $img,\n                              0,          # destX\n                              0,          # destY\n                              $left,      # srcX\n                              $top,       # srcY\n                              $right,     # destW\n                              $bottom,    # destH\n                              $right,     # srcW\n                              $bottom,    # srcH\n                             );\n\n        my $name = catfile($directory, basename($file));\n\n        if ($invisible) {\n            make_invisible_bg($cropped, $index, $bg_rgb, $cropped->width - 1, $cropped->height - 1);\n            $name =~ s/\\.\\w+\\z/.png/;\n        }\n\n        open my $fh, '>:raw', $name or die \"Can't create file `$name': $!\";\n        print $fh (\n                     $name =~ /\\.png\\z/i ? $cropped->png($png_compression)\n                   : $name =~ /\\.gif\\z/i ? $cropped->gif\n                   :                       $cropped->jpeg($jpeg_quality)\n                  );\n        close $fh;\n\n        say \" - ok!\";\n    }\n}\n\n@ARGV || help(1);\n\nif (not -d $directory) {\n    mkdir($directory) || die \"Can't mkdir `$directory': $!\";\n}\n\nautocrop(@ARGV);\n"
  },
  {
    "path": "Image/img_composition.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 15 April 2015\n# Edit: 18 September 2016\n# Website: https://github.com/trizen\n\n# Compose two images together by merging all the pixels, color by color.\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse GD;\n\nuse List::Util qw(min);\nuse Getopt::Long qw(GetOptions);\n\nGD::Image->trueColor(1);\n\nmy $output_file      = 'output.png';\nmy $scale_percentage = 0;\n\nsub usage {\n    print <<\"USAGE\";\nusage: $0 [options] [img1] [img2]\n\noptions:\n    -o  --output         : output file (default: $output_file)\n    -s  --scale-percent  : scale images by a given percentage (default: $scale_percentage)\n\nexample:\n    $0 -s -40 img1.png img2.jpg\nUSAGE\n    exit 2;\n}\n\nGetOptions(\n           'o|output=s'           => \\$output_file,\n           's|scale-percentage=i' => \\$scale_percentage,\n           'h|help'               => \\&usage,\n          );\n\nsub scale_image {\n    my ($img, $scale_percentage) = @_;\n\n    my ($width, $height) = $img->getBounds;\n\n    my $scale_width  = $width + int($scale_percentage / 100 * $width);\n    my $scale_height = $height + int($scale_percentage / 100 * $height);\n\n    my $scaled_gd = GD::Image->new($scale_width, $scale_height);\n    $scaled_gd->copyResampled($img, 0, 0, 0, 0, $scale_width, $scale_height, $width, $height);\n\n    return $scaled_gd;\n}\n\nsub make_matrix {\n    my ($file, $scale_percentage) = @_;\n\n    my $img = GD::Image->new($file) // do {\n        warn \"Can't load image `$file': $!\\n\";\n        return;\n    };\n\n    if ($scale_percentage != 0) {\n        $img = scale_image($img, $scale_percentage);\n    }\n\n    my @matrix;\n    my ($width, $height) = $img->getBounds();\n    foreach my $x (0 .. $width - 1) {\n        foreach my $y (0 .. $height - 1) {\n            $matrix[$x][$y] = [$img->rgb($img->getPixel($x, $y))];\n        }\n    }\n\n    return \\@matrix;\n}\n\nsub compose_images {\n    my ($A, $B) = @_;\n\n    local $| = 1;\n\n    my ($rows, $cols) = (min($#{$A}, $#{$B}), min($#{$A->[0]}, $#{$B->[0]}));\n\n    my @C;\n    foreach my $r (0 .. $rows) {\n        foreach my $i (0 .. $cols) {\n            foreach my $c (0 .. 2) {\n                $C[$i][$r][$c] = int(($A->[$r][$i][$c] + $B->[$r][$i][$c]) / 2);\n            }\n        }\n        print \"$r of $rows...\\r\";\n    }\n\n    return \\@C;\n}\n\nsub write_matrix {\n    my ($matrix, $file) = @_;\n\n    my ($rows, $cols) = ($#{$matrix}, $#{$matrix->[0]});\n    my $img = GD::Image->new($cols + 1, $rows + 1);\n\n    foreach my $y (0 .. $rows) {\n        foreach my $x (0 .. $cols) {\n            $img->setPixel($x, $y, $img->colorAllocate(@{$matrix->[$y][$x]}));\n        }\n    }\n\n    open my $fh, '>:raw', $file;\n    print $fh lc($file) =~ /\\.png\\z/\n      ? $img->png()\n      : $img->jpeg();\n    close $fh;\n\n}\n\nsay \"** Reading images...\";\nmy $A = make_matrix(shift(@ARGV) // usage(), $scale_percentage) // die \"error 1: $!\";\nmy $B = make_matrix(shift(@ARGV) // usage(), $scale_percentage) // die \"error 2: $!\";\n\nsay \"** Composing images...\";\nmy $C = compose_images($A, $B);\n\nsay \"** Writing the output image...\";\nwrite_matrix($C, $output_file)\n  ? (say \"** All done!\")\n  : (die \"Error: $!\");\n"
  },
  {
    "path": "Image/img_rewrite.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 30 January 2015\n# Website: https://github.com/trizen\n\n# Rewrite a set of images specified as arguments.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Image::Magick;\n\nforeach my $file (@ARGV) {\n    say \"** Processing file `$file'...\";\n    my $img = Image::Magick->new;\n    $img->Read($file) && do {\n        warn \"[!] Can't load image `$file' ($!). Skipping file...\\n\";\n        next;\n    };\n    unlink($file);\n    $img->Write($file);\n}\n"
  },
  {
    "path": "Image/julia_transform.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 11 March 2017\n# https://github.com/trizen\n\n# Julia transform of an image.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Julia_set\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager;\nuse Math::GComplex;\n\nmy $file = shift(@ARGV) // die \"usage: $0 [image]\\n\";\n\nsub map_val {\n    my ($value, $in_min, $in_max, $out_min, $out_max) = @_;\n\n#<<<\n    ($value - $in_min)\n        * ($out_max - $out_min)\n        / ($in_max - $in_min)\n    + $out_min;\n#>>>\n}\n\nmy $img = Imager->new(file => $file)\n  or die Imager->errstr();\n\nmy $width  = $img->getwidth;\nmy $height = $img->getheight;\n\nsub transform {\n    my ($x, $y) = @_;\n\n#<<<\n    my $z = Math::GComplex->new(\n        (2 * $x - $width ) / $width,\n        (2 * $y - $height) / $height,\n    );\n#>>>\n\n    state $c = Math::GComplex->new(-0.4, 0.6);\n\n    my $i = 10;\n    while ($z->abs < 2 and --$i >= 0) {\n        $z = $z * $z + $c;\n    }\n\n    $z->reals;\n}\n\nmy @matrix;\n\nmy ($min_x, $min_y) = ('inf') x 2;\nmy ($max_x, $max_y) = (-'inf') x 2;\n\nforeach my $y (0 .. $height - 1) {\n    foreach my $x (0 .. $width - 1) {\n        my ($new_x, $new_y) = transform($x, $y);\n\n        $matrix[$y][$x] = [$new_x, $new_y];\n\n        if ($new_x < $min_x) {\n            $min_x = $new_x;\n        }\n        if ($new_y < $min_y) {\n            $min_y = $new_y;\n        }\n        if ($new_x > $max_x) {\n            $max_x = $new_x;\n        }\n        if ($new_y > $max_y) {\n            $max_y = $new_y;\n        }\n    }\n}\n\nsay \"X: [$min_x, $max_x]\";\nsay \"Y: [$min_y, $max_y]\";\n\nmy $out_img = Imager->new(xsize => $width,\n                          ysize => $height);\n\nforeach my $y (0 .. $height - 1) {\n    foreach my $x (0 .. $width - 1) {\n        my ($new_x, $new_y) = @{$matrix[$y][$x]};\n        $new_x = map_val($new_x, $min_x, $max_x, 0, $width - 1);\n        $new_y = map_val($new_y, $min_y, $max_y, 0, $height - 1);\n        $out_img->setpixel(\n                           x     => $new_x,\n                           y     => $new_y,\n                           color => $img->getpixel(x => $x, y => $y),\n                          );\n    }\n}\n\n$out_img->write(file => 'julia_transform.png');\n"
  },
  {
    "path": "Image/lookalike_images.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 26 August 2015\n# Edit: 05 June 2021\n# https://github.com/trizen\n\n# Find images that look similar, given a main image.\n\n# Blog post:\n#   https://trizenx.blogspot.com/2015/08/finding-similar-images.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(bitwise signatures);\n\nuse Image::Magick qw();\nuse List::Util qw(sum);\nuse File::Find qw(find);\nuse Getopt::Long qw(GetOptions);\n\nmy $width      = 32;\nmy $height     = 32;\nmy $percentage = 60;\n\nmy $fuzzy_matching = 0;\nmy $copy_to        = undef;\n\nmy $resize_to = $width . 'x' . $height;\n\nmy @img_formats = qw(\n  jpeg\n  jpg\n  png\n);\n\nsub help ($code = 0) {\n    local $\" = \",\";\n    print <<\"EOT\";\nusage: $0 [options] [main image] [dir]\n\noptions:\n    -p  --percentage=i  : minimum similarity percentage (default: $percentage)\n    -r  --resize-to=s   : resize images to this resolution (default: $resize_to)\n    -f  --fuzzy!        : use fuzzy matching (default: $fuzzy_matching)\n    -c  --copy-to=s     : copy similar images into this directory\n\nexample:\n    perl $0 -p 75 -r '8x8' main.jpg ~/Pictures\nEOT\n\n    exit($code);\n}\n\nGetOptions(\n           'p|percentage=i' => \\$percentage,\n           'r|resize-to=s'  => \\$resize_to,\n           'f|fuzzy!'       => \\$fuzzy_matching,\n           'c|copy-to=s'    => \\$copy_to,\n           'h|help'         => sub { help(0) },\n          )\n  or die(\"Error in command line arguments\");\n\n($width, $height) = split(/\\h*x\\h*/i, $resize_to);\n\nmy $size = $width * $height;\n\nmy $img_formats_re = do {\n    local $\" = '|';\n    qr/\\.(@img_formats)\\z/i;\n};\n\nsub avg ($x, $y, $z) {\n    ($x + $y + $z) / 3;\n}\n\nsub alike_percentage ($x, $y) {\n    ((($x ^. $y) =~ tr/\\0//) / $size)**2 * 100;\n}\n\nsub fingerprint ($image) {\n\n    my $img = Image::Magick->new;\n    $img->Read(filename => $image) && return;\n    $img->AdaptiveResize(width => $width, height => $height) && return;\n\n    my @pixels = $img->GetPixels(\n                                 map       => 'RGB',\n                                 x         => 0,\n                                 y         => 0,\n                                 width     => $width,\n                                 height    => $height,\n                                 normalize => 1,\n                                );\n\n    my $i = 0;\n    my @averages;\n\n    while (@pixels) {\n\n        my $x = int($i % $width);\n        my $y = int($i / $width);\n\n        push @averages, avg(splice(@pixels, 0, 3));\n\n        ++$i;\n    }\n\n    my $avg = sum(@averages) / @averages;\n    join('', map { $_ < $avg ? 1 : 0 } @averages);\n}\n\nsub find_similar_images ($callback, $main_image, @paths) {\n\n    my @files;\n\n    find {\n        no_chdir => 1,\n        wanted   => sub {\n            (/$img_formats_re/o && -f) || return;\n\n            push @files,\n              {\n                fingerprint => fingerprint($_) // return,\n                filename    => $_,\n              };\n        }\n    } => @paths;\n\n    my $main_fingerprint = fingerprint($main_image) // return;\n\n    if ($fuzzy_matching) {\n\n        my %seen    = ($main_fingerprint => 1);\n        my @similar = ($main_fingerprint);\n\n        my @similar_files;\n\n        while (@similar) {\n\n            my $similar_fingerprint = shift(@similar);\n\n            foreach my $file (@files) {\n\n                my $p = alike_percentage($similar_fingerprint, $file->{fingerprint});\n\n                if ($p >= $percentage and !$seen{$file->{fingerprint}}++) {\n                    push @similar, $file->{fingerprint};\n                    push @similar_files, {score => $p, filename => $file->{filename}};\n                }\n            }\n        }\n\n        foreach my $entry (sort { $b->{score} <=> $a->{score} } @similar_files) {\n            $callback->($entry->{score}, $entry->{filename});\n        }\n    }\n    else {\n        foreach my $file (@files) {\n\n            my $p = alike_percentage($main_fingerprint, $file->{fingerprint});\n\n            if ($p >= $percentage) {\n                $callback->($p, $file->{filename});\n            }\n        }\n    }\n\n    return 1;\n}\n\nmy $main_file = shift(@ARGV) // help(1);\n\n@ARGV || help(1);\n\nif (defined($copy_to)) {\n\n    require File::Copy;\n\n    if (not -d $copy_to) {\n        require File::Path;\n        File::Path::make_path($copy_to)\n          or die \"Can't create path <<$copy_to>>: $!\";\n    }\n}\n\nfind_similar_images(\n    sub ($score, $file) {\n\n        say sprintf(\"%.0f%%: %s\", $score, $file);\n\n        if ($copy_to) {\n            File::Copy::cp($file, $copy_to);\n        }\n    },\n    $main_file,\n    @ARGV\n                   );\n"
  },
  {
    "path": "Image/magick_png2jpg.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 23 March 2021\n# https://github.com/trizen\n\n# Convert PNG images to JPEG, using the ImageMagick library.\n\n# The original PNG files are deleted.\n\nuse 5.036;\nuse File::Find    qw(find);\nuse Image::Magick qw();\nuse Getopt::Long  qw(GetOptions);\n\nmy $batch_size   = 100;    # how many files to process at once\nmy $use_exiftool = 0;      # true to use `exiftool` instead of `File::MimeInfo::Magic`\n\nsub convert_PNGs (@files) {\n\n    say \":: Converting a batch of \", scalar(@files), \" PNG images...\";\n\n    foreach my $file (@files) {\n        say \":: Processing: $file\";\n\n        my $image = Image::Magick->new;\n\n        $image->Read(filename => $file) && do {\n            warn \"[!] Can't load file <<$file>>. Skipping...\\n\";\n            next;\n        };\n\n        my $orig_file = $file;\n        my $jpeg_file = $file;\n\n        if ($jpeg_file =~ s/\\.png\\z/.jpg/i) {\n            ## ok\n        }\n        else {\n            $jpeg_file .= '.jpg';\n        }\n\n        if (-e $jpeg_file) {\n            warn \"[!] File <<$jpeg_file>> already exists...\\n\";\n            next;\n        }\n\n        open(my $fh, '>:raw', $jpeg_file) or do {\n            warn \"[!] Can't open file <<$jpeg_file>> for writing: $!\\n\";\n            next;\n        };\n\n        $image->Write(file => $fh, filename => $jpeg_file);\n\n        close $fh;\n\n        if (-e $jpeg_file and ($orig_file ne $jpeg_file)) {\n            say \":: Saved as: $jpeg_file\";\n            unlink($orig_file);    # remove the original PNG file\n        }\n    }\n}\n\nsub determine_mime_type ($file) {\n\n    if ($file =~ /\\.jpe?g\\z/i) {\n        return \"image/jpeg\";\n    }\n\n    if ($file =~ /\\.png\\z/i) {\n        return \"image/png\";\n    }\n\n    if ($use_exiftool) {\n        my $res = `exiftool \\Q$file\\E`;\n        $? == 0       or return;\n        defined($res) or return;\n        if ($res =~ m{^MIME\\s+Type\\s*:\\s*(\\S+)}mi) {\n            return $1;\n        }\n        return;\n    }\n\n    require File::MimeInfo::Magic;\n    File::MimeInfo::Magic::magic($file);\n}\n\nmy %types = (\n             'image/png' => {\n                             files => [],\n                             call  => \\&convert_PNGs,\n                            },\n            );\n\nGetOptions('exiftool!'    => \\$use_exiftool,\n           'batch-size=i' => \\$batch_size,)\n  or die \"Error in command-line arguments!\";\n\n@ARGV or die <<\"USAGE\";\nusage: perl $0 [options] [dirs | files]\n\noptions:\n\n    --batch=i  : how many files to process at once (default: $batch_size)\n    --exiftool : use `exiftool` to determine the MIME type (default: $use_exiftool)\n\nUSAGE\n\nfind(\n    {\n     no_chdir => 1,\n     wanted   => sub {\n\n         (-f $_) || return;\n         my $type = determine_mime_type($_) // return;\n\n         if (exists $types{$type}) {\n\n             my $ref = $types{$type};\n             push @{$ref->{files}}, $_;\n\n             if (scalar(@{$ref->{files}}) >= $batch_size) {\n                 $ref->{call}->(splice(@{$ref->{files}}));\n             }\n         }\n     }\n    } => @ARGV\n);\n\nforeach my $type (keys %types) {\n\n    my $ref = $types{$type};\n\n    if (@{$ref->{files}}) {\n        $ref->{call}->(splice(@{$ref->{files}}));\n    }\n}\n\nsay \":: Done!\";\n"
  },
  {
    "path": "Image/magick_similar_images.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 26 August 2015\n# Edit: 25 October 2023\n# Website: https://github.com/trizen\n\n# Find images that look similar.\n\n# Blog post:\n#   https://trizenx.blogspot.com/2015/08/finding-similar-images.html\n\nuse 5.022;\nuse strict;\nuse warnings;\n\nuse experimental 'bitwise';\n\nuse Image::Magick qw();\nuse List::Util    qw(sum);\nuse File::Find    qw(find);\nuse Getopt::Long  qw(GetOptions);\n\nmy $width      = 32;\nmy $height     = 32;\nmy $percentage = 90;\n\nmy $keep_only   = undef;\nmy $img_formats = '';\nmy $resize_to   = $width . 'x' . $height;\n\nmy @img_formats = qw(\n  jpeg\n  jpg\n  png\n);\n\nsub help {\n    my ($code) = @_;\n    local $\" = \",\";\n    print <<\"EOT\";\nusage: $0 [options] [dir]\n\noptions:\n    -p  --percentage=i  : minimum similarity percentage (default: $percentage)\n    -r  --resize-to=s   : resize images to this resolution (default: $resize_to)\n    -f  --formats=s,s   : specify more image formats (default: @img_formats)\n    -k  --keep=s        : keep only the 'smallest' or 'largest' image from each group\n\nWARNING: option '-k' permanently removes your images!\n\nexample:\n    perl $0 -p 75 -r '8x8' ~/Pictures\nEOT\n\n    exit($code);\n}\n\nGetOptions(\n           'p|percentage=i' => \\$percentage,\n           'r|resize-to=s'  => \\$resize_to,\n           'f|formats=s'    => \\$img_formats,\n           'k|keep=s'       => \\$keep_only,\n           'h|help'         => sub { help(0) },\n          )\n  or die(\"Error in command line arguments\");\n\n($width, $height) = split(/\\h*x\\h*/i, $resize_to);\n\nmy $size = $width * $height;\npush @img_formats, map { quotemeta } split(/\\s*,\\s*/, $img_formats);\n\nmy $img_formats_re = do {\n    local $\" = '|';\n    qr/\\.(@img_formats)\\z/i;\n};\n\n#<<<\nsub alike_percentage {\n    ((($_[0] ^. $_[1]) =~ tr/\\0//) / $size)**2 * 100;\n}\n#>>>\n\nsub fingerprint {\n    my ($image) = @_;\n\n    my $img = Image::Magick->new;\n    $img->Read(filename => $image) && return;\n\n    $img->AdaptiveResize(width => $width, height => $height) && return;   # balanced\n    ## $img->Resize(width => $width, height => $height) && return;        # better, but slower\n    ## $img->Resample(width => $width, height => $height) && return;      # faster, but worse\n\n    my @pixels = $img->GetPixels(\n                                 map       => 'RGB',\n                                 x         => 0,\n                                 y         => 0,\n                                 width     => $width,\n                                 height    => $height,\n                                 normalize => 1,\n                                );\n\n    my @averages;\n\n    while (@pixels) {\n        push @averages, sum(splice(@pixels, 0, 3))/3;\n    }\n\n    my $avg = sum(@averages) / @averages;\n    join('', map { ($_ < $avg) ? 1 : 0 } @averages);\n}\n\nsub find_similar_images(&@) {\n    my $callback = shift;\n\n    my @files;\n    find {\n        no_chdir => 1,\n        wanted   => sub {\n            (/$img_formats_re/o && -f) || return;\n\n            push @files,\n              {\n                fingerprint => fingerprint($_) // return,\n                filename    => $_,\n              };\n        }\n    } => @_;\n\n    #\n    ## Populate the %alike hash\n    #\n    my %alike;\n    foreach my $i (0 .. $#files - 1) {\n        for (my $j = $i + 1 ; $j <= $#files ; $j++) {\n            my $p = alike_percentage($files[$i]{fingerprint}, $files[$j]{fingerprint});\n            if ($p >= $percentage) {\n                $alike{$files[$i]{filename}}{$files[$j]{filename}} = $p;\n                $alike{$files[$j]{filename}}{$files[$i]{filename}} = $p;\n            }\n        }\n    }\n\n    #\n    ## Group the files\n    #\n    my @alike;\n    foreach my $root (\n        map  { $_->[0] }\n        sort { ($a->[1] <=> $b->[1]) || ($b->[2] <=> $a->[2]) }\n        map {\n            my $keys = keys(%{$alike{$_}});\n            my $avg  = sum(values(%{$alike{$_}})) / $keys;\n\n            [$_, $keys, $avg]\n        }\n        keys %alike\n      ) {\n        my @group = keys(%{$alike{$root}});\n        if (@group) {\n            my $avg = 0;\n            $avg += delete($alike{$_}{$root}) for @group;\n            push @alike, {score => $avg / @group, files => [$root, @group]};\n\n        }\n    }\n\n    #\n    ## Callback each group\n    #\n    my %seen;\n    foreach my $group (sort { $b->{score} <=> $a->{score} } @alike) {\n        (@{$group->{files}} == grep { $seen{$_}++ } @{$group->{files}}) and next;\n        $callback->($group->{score}, $group->{files});\n    }\n\n    return 1;\n}\n\n@ARGV || help(1);\nfind_similar_images {\n    my ($score, $files) = @_;\n\n    printf(\"=> Similarity: %.0f%%\\n\", $score);\n    say join(\"\\n\", sort @{$files});\n    say \"-\" x 80;\n\n    if (defined($keep_only)) {\n\n        my @existent_files = grep { -f $_ } @$files;\n\n        scalar(@existent_files) > 1 or return;\n\n        my @sorted_by_size = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [$_, -s $_] } @existent_files;\n        if ($keep_only =~ /large/i) {\n            pop(@sorted_by_size);\n        }\n        elsif ($keep_only =~ /small/i) {\n            shift(@sorted_by_size);\n        }\n        else {\n            die \"error: unknown value <<$keep_only>> for option `-k`!\\n\";\n        }\n        foreach my $file (@sorted_by_size) {\n            say \"Removing: $file\";\n            unlink($file) or warn \"Failed to remove: $!\";\n        }\n    }\n} @ARGV;\n"
  },
  {
    "path": "Image/magick_star_trails.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 30 January 2015\n# Edited: 31 January 2015\n# Website: https://github.com/trizen\n\n# Merge two or more images together and keep the most intensive pixel colors\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse Image::Magick;\nuse List::Util   qw(min max);\nuse Getopt::Long qw(GetOptions);\n\nmy $output_file   = 'output.png';\nmy $scale_percent = 0;\nmy $brightness_f  = 'avg';\n\nmy %brightness = (\n\n    # I: https://en.wikipedia.org/wiki/HSL_and_HSV#Lightness\n    avg => sub { ($_[0] + $_[1] + $_[2]) / 3 },\n\n    # L: https://en.wikipedia.org/wiki/HSL_and_HSV#Lightness\n    hsl => sub { 0.5 * max(@_) + 0.5 * min(@_) },\n\n    # https://en.wikipedia.org/wiki/Relative_luminance\n    rl => sub { (0.2126 * $_[0] + 0.7152 * $_[1] + 0.0722 * $_[2]) },\n\n    # https://en.wikipedia.org/wiki/Luma_(video)#Rec._601_luma_versus_Rec._709_luma_coefficients\n    luma => sub { (0.299 * $_[0] + 0.587 * $_[1] + 0.114 * $_[2]) },\n\n    # http://alienryderflex.com/hsp.html\n    hsp => sub { sqrt(0.299 * ($_[0]**2) + 0.587 * ($_[1]**2) + 0.114 * ($_[2]**2)) },\n);\n\nsub help {\n    local $\" = \", \";\n    print <<\"HELP\";\nusage: $0 [options] [files]\n\noptions:\n    -o  --output         : output file (default: $output_file)\n    -s  --scale-percent  : scale image by a given percentage (default: $scale_percent)\n    -f  --formula        : formula for the brightness of a pixel (default: $brightness_f)\n                           valid values: @{[sort keys %brightness]}\n\nexample:\n    $0 -o merged.png --scale -20 file1.jpg file2.jpg\nHELP\n    exit;\n}\n\nGetOptions(\n           'o|output=s'        => \\$output_file,\n           's|scale-percent=i' => \\$scale_percent,\n           'f|formula=s'       => \\$brightness_f,\n           'h|help'            => \\&help,\n          )\n  or die \"Error in command-line arguments!\";\n\nif (not exists $brightness{$brightness_f}) {\n    local $\" = \", \";\n    die \"[!] Invalid brightness formula: `$brightness_f'.\n        Valid values are: @{[sort keys %brightness]}\\n\";\n}\n\nmy $lightness_function = $brightness{$brightness_f};\n\nmy @matrix;\nforeach my $image (@ARGV) {\n\n    say \"** Processing file: $image\";\n\n    my $img = Image::Magick->new;\n    my $err = $img->Read($image);\n\n    if ($err) {\n        warn \"** Can't load file <<$image>> ($err). Skipping...\\n\";\n        next;\n    }\n\n    my ($width, $height) = $img->Get('width', 'height');\n\n    if ($scale_percent != 0) {\n        my $scale_width  = $width + int($scale_percent / 100 * $width);\n        my $scale_height = $height + int($scale_percent / 100 * $height);\n        $img->Resize(width => $scale_width, height => $scale_height);\n        ($width, $height) = ($scale_width, $scale_height);\n    }\n\n    my @pixels = $img->GetPixels(\n                                 map       => 'RGB',\n                                 x         => 0,\n                                 y         => 0,\n                                 width     => $width,\n                                 height    => $height,\n                                 normalize => 1,\n                                );\n\n    my $i = 0;\n    while (@pixels) {\n\n        my $x = int($i % $width);\n        my $y = int($i / $width);\n\n        my @rgb = splice(@pixels, 0, 3);\n\n        $matrix[$x][$y] //= [0, 0, 0];\n        if ($lightness_function->(@{$matrix[$x][$y]}) < $lightness_function->(@rgb)) {\n            $matrix[$x][$y] = \\@rgb;\n        }\n\n        ++$i;\n    }\n}\n\n@matrix || die \"error: No image has been processed!\\n\";\nsay \"** Creating the output image: $output_file\";\n\nmy $image = Image::Magick->new;\n$image->Set(size => @matrix . 'x' . @{$matrix[0]});\n$image->ReadImage('canvas:white');\n\nforeach my $x (0 .. $#matrix) {\n    my $row = $matrix[$x] // next;\n    foreach my $y (0 .. $#{$matrix[0]}) {\n        my $entry = $row->[$y] // next;\n        $image->SetPixel(x => $x, y => $y, color => $entry);\n    }\n}\n\nopen my $fh, '>:raw', $output_file;\n$image->Write(file => $fh, filename => $output_file);\nclose $fh;\n\nsay \"** All done!\";\n"
  },
  {
    "path": "Image/matrix_visual.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 13 August 2016\n# Website: https://github.com/trizen\n\n# Display a matrix as a rectangle packed with circles.\n\n# Brighter circles represent larger numerical values,\n# while dimmer circles represent smaller numerical values.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Imager;\nuse List::MoreUtils qw(minmax);\n\nmy @matrix = (\n              [131, 673, 234, 103, 18],\n              [201, 96,  342, 965, 150],\n              [630, 803, 746, 422, 111],\n              [537, 699, 497, 121, 956],\n              [805, 732, 524, 37,  331],\n             );\n\n#<<<\n# Reading a matrix from the standard input.\n#~ @matrix = ();\n#~ while(<>) {\n    #~ chomp;\n    #~ push @matrix, [split(/,/, $_)];\n#~ }\n#>>>\n\nmy $max_color    = 2**16 - 1;\nmy $scale_factor = 10;\nmy $radius       = $scale_factor / atan2(0, -'inf');\nmy $space        = $radius / 2;\n\nmy $img = Imager->new(\n                      xsize    => @{$matrix[0]} * $scale_factor,\n                      ysize    => @matrix * $scale_factor,\n                      channels => 3,\n                     );\n\nmy ($min, $max) = minmax(map { @$_ } @matrix);\n\nforeach my $i (0 .. $#matrix) {\n    my $row = $matrix[$i];\n    foreach my $j (0 .. $#{$row}) {\n        my $cell = $row->[$j];\n\n        my $value = int($max_color / ($max - $min) * ($cell - $min));\n        my $color = Imager::Color->new(sprintf(\"#%06x\", $value));\n\n        $img->circle(\n                     r     => $radius,\n                     x     => int($j * $scale_factor + $radius + $space),\n                     y     => int($i * $scale_factor + $radius + $space),\n                     color => $color,\n                    );\n    }\n}\n\n$img->write(file => 'matrix_circle.png');\n"
  },
  {
    "path": "Image/mirror_images.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 04 June 2024\n# https://github.com/trizen\n\n# Mirror a given list of images (horizontal flip).\n\nuse 5.036;\nuse Imager       qw();\nuse File::Find   qw(find);\nuse Getopt::Long qw(GetOptions);\n\nmy $img_formats = '';\n\nmy @img_formats = qw(\n  jpeg\n  jpg\n  png\n);\n\nsub usage ($code) {\n    local $\" = \",\";\n    print <<\"EOT\";\nusage: $0 [options] [dirs | files]\n\noptions:\n    -f  --formats=s,s   : specify more image formats (default: @img_formats)\n\nexample:\n    perl $0 ~/Pictures\nEOT\n\n    exit($code);\n}\n\nGetOptions('f|formats=s' => \\$img_formats,\n           'help'        => sub { usage(0) },)\n  or die(\"Error in command line arguments\");\n\npush @img_formats, map { quotemeta } split(/\\s*,\\s*/, $img_formats);\n\nmy $img_formats_re = do {\n    local $\" = '|';\n    qr/\\.(@img_formats)\\z/i;\n};\n\nsub mirror_image ($image) {\n\n    my $img = Imager->new(file => $image) or do {\n        warn \"Failed to load <<$image>>: \", Imager->errstr();\n        return;\n    };\n\n    $img->flip(dir => \"h\");\n    $img->write(file => $image);\n}\n\n@ARGV || usage(1);\n\nfind {\n    no_chdir => 1,\n    wanted   => sub {\n        (/$img_formats_re/o && -f) || return;\n        say \"Mirroring: $_\";\n        mirror_image($_);\n    }\n} => @ARGV;\n"
  },
  {
    "path": "Image/mtf_horizontal_transform.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 06 April 2024\n# Edit: 09 April 2024\n# https://github.com/trizen\n\n# Scramble the pixels in each row inside an image, using the Move-to-front transform (MTF).\n\nuse 5.036;\nuse GD;\nuse Getopt::Std       qw(getopts);\nuse Compression::Util qw(mtf_encode mtf_decode);\n\nGD::Image->trueColor(1);\n\nsub scramble_image ($file, $function) {\n\n    my $image = GD::Image->new($file) || die \"Can't open file <<$file>>: $!\";\n    my ($width, $height) = $image->getBounds();\n\n    my $new_image = GD::Image->new($width, $height);\n    my @alphabet  = (0 .. 255);\n\n    foreach my $y (0 .. $height - 1) {\n\n        my @row;\n        foreach my $x (0 .. $width - 1) {\n            push @row, $image->rgb($image->getPixel($x, $y));\n        }\n\n        @row = @{$function->(\\@row, \\@alphabet)};\n\n        foreach my $x (0 .. $width - 1) {\n            $new_image->setPixel($x, $y, $new_image->colorAllocate(splice(@row, 0, 3)));\n        }\n    }\n\n    return $new_image;\n}\n\nsub usage ($exit_code = 0) {\n\n    print <<\"EOT\";\nusage: $0 [options] [input.png] [output.png]\n\noptions:\n\n    -d : decode the image\n    -h : print this message and exit\n\nEOT\n\n    exit($exit_code);\n}\n\ngetopts('dh', \\my %opts);\n\nmy $input_file  = $ARGV[0] // usage(2);\nmy $output_file = $ARGV[1] // \"output.png\";\n\nif (not -f $input_file) {\n    die \"Input file <<$input_file>> does not exist!\\n\";\n}\n\nmy $img = $opts{d} ? scramble_image($input_file, \\&mtf_decode) : scramble_image($input_file, \\&mtf_encode);\nopen(my $out_fh, '>:raw', $output_file) or die \"can't create output file <<$output_file>>: $!\";\nprint $out_fh $img->png(9);\nclose $out_fh;\n"
  },
  {
    "path": "Image/mtf_vertical_transform.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 06 April 2024\n# Edit: 09 April 2024\n# https://github.com/trizen\n\n# Scramble the pixels in each column inside an image, using the Move-to-front transform (MTF).\n\nuse 5.036;\nuse GD;\nuse Getopt::Std       qw(getopts);\nuse Compression::Util qw(mtf_encode mtf_decode);\n\nGD::Image->trueColor(1);\n\nsub scramble_image ($file, $function) {\n\n    my $image = GD::Image->new($file) || die \"Can't open file <<$file>>: $!\";\n    my ($width, $height) = $image->getBounds();\n\n    my $new_image = GD::Image->new($width, $height);\n    my @alphabet  = (0 .. 255);\n\n    foreach my $x (0 .. $width - 1) {\n\n        my @column;\n        foreach my $y (0 .. $height - 1) {\n            push @column, $image->rgb($image->getPixel($x, $y));\n        }\n\n        @column = @{$function->(\\@column, \\@alphabet)};\n\n        foreach my $y (0 .. $height - 1) {\n            $new_image->setPixel($x, $y, $new_image->colorAllocate(splice(@column, 0, 3)));\n        }\n    }\n\n    return $new_image;\n}\n\nsub usage ($exit_code = 0) {\n\n    print <<\"EOT\";\nusage: $0 [options] [input.png] [output.png]\n\noptions:\n\n    -d : decode the image\n    -h : print this message and exit\n\nEOT\n\n    exit($exit_code);\n}\n\ngetopts('dh', \\my %opts);\n\nmy $input_file  = $ARGV[0] // usage(2);\nmy $output_file = $ARGV[1] // \"output.png\";\n\nif (not -f $input_file) {\n    die \"Input file <<$input_file>> does not exist!\\n\";\n}\n\nmy $img = $opts{d} ? scramble_image($input_file, \\&mtf_decode) : scramble_image($input_file, \\&mtf_encode);\nopen(my $out_fh, '>:raw', $output_file) or die \"can't create output file <<$output_file>>: $!\";\nprint $out_fh $img->png(9);\nclose $out_fh;\n"
  },
  {
    "path": "Image/nearest_neighbor_interpolation.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 27 July 2018\n# https://github.com/trizen\n\n# A simple implementation of the nearest-neighbor interpolation algorithm for scaling up an image.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Nearest-neighbor_interpolation\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Imager;\nuse experimental qw(signatures);\n\nsub nearest_neighbor_interpolation ($file, $zoom = 2) {\n\n    my $img = Imager->new(file => $file)\n      or die Imager->errstr();\n\n    my $width  = $img->getwidth;\n    my $height = $img->getheight;\n\n    my $out_img = Imager->new(xsize => $zoom * $width,\n                              ysize => $zoom * $height);\n\n    foreach my $y (0 .. $height - 1) {\n        foreach my $x (0 .. $width - 1) {\n            my $pixel = $img->getpixel(x => $x, y => $y);\n#<<<\n            # Fill the gaps\n            $out_img->setpixel(x => $zoom * $x,     y => $zoom * $y,     color => $pixel);\n            $out_img->setpixel(x => $zoom * $x + 1, y => $zoom * $y + 1, color => $pixel);\n            $out_img->setpixel(x => $zoom * $x + 1, y => $zoom * $y,     color => $pixel);\n            $out_img->setpixel(x => $zoom * $x,     y => $zoom * $y + 1, color => $pixel);\n#>>>\n        }\n    }\n\n    return $out_img;\n}\n\nmy $file = shift(@ARGV) // die \"usage: $0 [image]\\n\";\nmy $img  = nearest_neighbor_interpolation($file, 2);\n\n$img->write(file => \"output.png\");\n"
  },
  {
    "path": "Image/optimize_images.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 09 October 2019\n# https://github.com/trizen\n\n# Optimize JPEG and PNG images in a given directory (recursively) using the \"jpegoptim\" and \"optipng\" tools.\n\nuse 5.036;\nuse File::Find   qw(find);\nuse Getopt::Long qw(GetOptions);\n\nmy $batch_size   = 100;    # how many files to process at once\nmy $use_exiftool = 0;      # true to use `exiftool` instead of `File::MimeInfo::Magic`\n\nsub optimize_JPEGs (@files) {\n\n    say \":: Optimizing a batch of \", scalar(@files), \" JPEG images...\";\n\n    system(\n        \"jpegoptim\",\n        \"--preserve\",    # preserve file modification times\n        ##'--max=90',\n        ##'--size=2048',\n        '--all-progressive',\n        @files\n          );\n}\n\nsub optimize_PNGs (@files) {\n\n    say \":: Optimizing a batch of \", scalar(@files), \" PNG images...\";\n\n    system(\n        \"optipng\",\n        \"-preserve\",    # preserve file attributes if possible\n        \"-o1\",          # optimization level\n        @files\n          );\n}\n\nsub determine_mime_type ($file) {\n\n    if ($file =~ /\\.jpe?g\\z/i) {\n        return \"image/jpeg\";\n    }\n\n    if ($file =~ /\\.png\\z/i) {\n        return \"image/png\";\n    }\n\n    if ($use_exiftool) {\n        my $res = `exiftool \\Q$file\\E`;\n        $? == 0       or return;\n        defined($res) or return;\n        if ($res =~ m{^MIME\\s+Type\\s*:\\s*(\\S+)}mi) {\n            return $1;\n        }\n        return;\n    }\n\n    require File::MimeInfo::Magic;\n    File::MimeInfo::Magic::magic($file);\n}\n\nmy %types = (\n             'image/jpeg' => {\n                              files => [],\n                              call  => \\&optimize_JPEGs,\n                             },\n             'image/png' => {\n                             files => [],\n                             call  => \\&optimize_PNGs,\n                            },\n            );\n\nGetOptions('exiftool!'    => \\$use_exiftool,\n           'batch-size=i' => \\$batch_size,)\n  or die \"Error in command-line arguments!\";\n\n@ARGV or die <<\"USAGE\";\nusage: perl $0 [options] [dirs | files]\n\noptions:\n\n    --batch=i  : how many files to process at once (default: $batch_size)\n    --exiftool : use `exiftool` to determine the MIME type (default: $use_exiftool)\n\nUSAGE\n\nfind(\n    {\n     no_chdir => 1,\n     wanted   => sub {\n\n         (-f $_) || return;\n         my $type = determine_mime_type($_) // return;\n\n         if (exists $types{$type}) {\n\n             my $ref = $types{$type};\n             push @{$ref->{files}}, $_;\n\n             if (scalar(@{$ref->{files}}) >= $batch_size) {\n                 $ref->{call}->(splice(@{$ref->{files}}));\n             }\n         }\n     }\n    } => @ARGV\n);\n\nforeach my $type (keys %types) {\n\n    my $ref = $types{$type};\n\n    if (@{$ref->{files}}) {\n        $ref->{call}->(splice(@{$ref->{files}}));\n    }\n}\n\nsay \":: Done!\";\n"
  },
  {
    "path": "Image/optimize_images_littleutils.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 19 December 2020\n# https://github.com/trizen\n\n# Optimize JPEG, PNG and GIF images in a given directory (recursively) using the \"opt-png\", \"opt-jpg\" and \"opt-gif\" tools from littleutils.\n\n# Littleutils:\n#   https://sourceforge.net/projects/littleutils/\n\nuse 5.036;\nuse File::Find   qw(find);\nuse Getopt::Long qw(GetOptions);\n\nmy $batch_size   = 100;    # how many files to process at once\nmy $use_exiftool = 0;      # true to use `exiftool` instead of `File::MimeInfo::Magic`\n\nsub optimize_JPEGs (@files) {\n\n    say \":: Optimizing a batch of \", scalar(@files), \" JPEG images...\";\n\n    system(\n        \"opt-jpg\",\n        \"-m\", \"all\",    # copy all extra markers\n        \"-t\",           # preserve timestamp on modified files\n        @files\n          );\n}\n\nsub optimize_PNGs (@files) {\n\n    say \":: Optimizing a batch of \", scalar(@files), \" PNG images...\";\n\n    system(\n        \"opt-png\",\n        \"-t\",           # preserve timestamp on modified files\n        @files\n          );\n}\n\nsub optimize_GIFs (@files) {\n\n    say \":: Optimizing a batch of \", scalar(@files), \" GIF images...\";\n\n    system(\n        \"opt-gif\",\n        \"-t\",           # preserve timestamp on modified files\n        @files\n          );\n}\n\nsub determine_mime_type ($file) {\n\n    if ($file =~ /\\.jpe?g\\z/i) {\n        return \"image/jpeg\";\n    }\n\n    if ($file =~ /\\.png\\z/i) {\n        return \"image/png\";\n    }\n\n    if ($use_exiftool) {\n        my $res = `exiftool \\Q$file\\E`;\n        $? == 0       or return;\n        defined($res) or return;\n        if ($res =~ m{^MIME\\s+Type\\s*:\\s*(\\S+)}mi) {\n            return $1;\n        }\n        return;\n    }\n\n    require File::MimeInfo::Magic;\n    File::MimeInfo::Magic::magic($file);\n}\n\nmy %types = (\n             'image/jpeg' => {\n                              files => [],\n                              call  => \\&optimize_JPEGs,\n                             },\n             'image/png' => {\n                             files => [],\n                             call  => \\&optimize_PNGs,\n                            },\n             'image/gif' => {\n                             files => [],\n                             call  => \\&optimize_GIFs,\n                            },\n            );\n\nGetOptions('exiftool!'    => \\$use_exiftool,\n           'batch-size=i' => \\$batch_size,)\n  or die \"Error in command-line arguments!\";\n\n@ARGV or die <<\"USAGE\";\nusage: perl $0 [options] [dirs | files]\n\noptions:\n\n    --batch=i  : how many files to process at once (default: $batch_size)\n    --exiftool : use `exiftool` to determine the MIME type (default: $use_exiftool)\n\nUSAGE\n\nfind(\n    {\n     no_chdir => 1,\n     wanted   => sub {\n\n         (-f $_) || return;\n         my $type = determine_mime_type($_) // return;\n\n         if (exists $types{$type}) {\n\n             my $ref = $types{$type};\n             push @{$ref->{files}}, $_;\n\n             if (scalar(@{$ref->{files}}) >= $batch_size) {\n                 $ref->{call}->(splice(@{$ref->{files}}));\n             }\n         }\n     }\n    } => @ARGV\n);\n\nforeach my $type (keys %types) {\n\n    my $ref = $types{$type};\n\n    if (@{$ref->{files}}) {\n        $ref->{call}->(splice(@{$ref->{files}}));\n    }\n}\n\nsay \":: Done!\";\n"
  },
  {
    "path": "Image/outguess-png-imager.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 07 February 2022\n# https://github.com/trizen\n\n# Hide arbitrary data into the pixels of a PNG image, storing 3 bits in each pixel color.\n\n# Concept inspired by outguess:\n#   https://github.com/resurrecting-open-source-projects/outguess\n#   https://uncovering-cicada.fandom.com/wiki/OutGuess\n\n# Q: How does it work?\n# A: The script uses the Imager library to read the RGB color values of each pixel.\n#    Then it changes the last bit of each value to one bit from the data to be encoded.\n\n# Q: How does the decoding work?\n# A: The first 32 bits from the first 32 pixels of the image, form the length of the encoded data.\n#    Then the remaining bits (3 bits from each pixel) are collected to form the encoded data.\n\n# The script also does transparent Deflate compression and decompression of the encoded data.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nno warnings 'once';\n\nuse Imager;\nuse Getopt::Long qw(GetOptions);\nuse experimental qw(signatures);\n\nbinmode(STDIN,  ':raw');\nbinmode(STDOUT, ':raw');\n\nsub encode_data ($data, $img_file) {\n\n    my $image = Imager->new(file => $img_file)\n      or die Imager->errstr();\n\n    require IO::Compress::RawDeflate;\n    IO::Compress::RawDeflate::rawdeflate(\\$data, \\my $compressed_data)\n      or die \"rawdeflate failed: $IO::Compress::RawDeflate::RawDeflateError\\n\";\n\n    $data = $compressed_data;\n\n    my $bin    = unpack(\"B*\", $data);\n    my $width  = $image->getwidth();\n    my $height = $image->getheight();\n\n    my $maximum_data_size = 3 * (($width * $height - 32) >> 3);\n    my $data_size         = length($bin) >> 3;\n\n    if ($data_size == 0) {\n        die sprintf(\"No data was given!\\n\");\n    }\n\n    if ($data_size > $maximum_data_size) {\n        die sprintf(\n                    \"Data is too large (%s bytes) for this image (exceeded by %.2f%%).\\n\"\n                      . \"Maximum data size for this image is %s bytes.\\n\",\n                    $data_size, 100 - ($maximum_data_size / $data_size * 100),\n                    $maximum_data_size\n                   );\n    }\n\n    warn sprintf(\"Compressed data size: %s bytes (%.2f%% out of max %s bytes)\\n\",\n                 $data_size, $data_size / $maximum_data_size * 100,\n                 $maximum_data_size);\n\n    my $length_bin = unpack(\"B*\", pack(\"N*\", $data_size));\n\n    $bin = reverse($length_bin . $bin);\n\n    my $size = length($bin);\n\n  OUTER: foreach my $y (0 .. $height - 1) {\n        my $x = 0;\n        foreach my $color ($image->getscanline(x => 0, y => $y, width => $width)) {\n\n            if ($size > 0) {\n                my ($red, $green, $blue, $alpha) = $color->rgba;\n                $color->set((map { (($_ >> 1) << 1) | (chop($bin) || 0) } ($red, $green, $blue)), $alpha);\n                $size -= 3;\n            }\n            else {\n                last OUTER;\n            }\n\n            $image->setpixel(x => $x++, y => $y, color => $color);\n        }\n    }\n\n    return $image;\n}\n\nsub decode_data ($img_file) {\n\n    my $image = Imager->new(file => $img_file)\n      or die Imager->errstr();\n\n    my $width  = $image->getwidth;\n    my $height = $image->getheight;\n\n    my $bin  = '';\n    my $size = 0;\n\n    my $length        = $width * $height;\n    my $find_length   = 1;\n    my $max_data_size = 3 * ($length - 4);\n\n  OUTER: foreach my $y (0 .. $height - 1) {\n        foreach my $color ($image->getscanline(x => 0, y => $y, width => $width)) {\n\n            if ($size < $length) {\n\n                my ($red, $green, $blue) = $color->rgba;\n                $bin .= join('', map { $_ & 1 } ($red, $green, $blue));\n                $size += 3;\n\n                if ($find_length and $size >= 32) {\n\n                    $length      = unpack(\"N*\", pack(\"B*\", substr($bin, 0, 32)));\n                    $find_length = 0;\n                    $size        = length($bin) - 32;\n                    $bin         = substr($bin, 32);\n\n                    if ($length > $max_data_size or $length == 0) {\n                        die \"No hidden data was found in this image!\\n\";\n                    }\n\n                    warn sprintf(\"Compressed data size: %s bytes\\n\", $length);\n                    $length <<= 3;\n                }\n            }\n            else {\n                last OUTER;\n            }\n        }\n    }\n\n    my $data = pack(\"B*\", substr($bin, 0, $length));\n\n    require IO::Uncompress::RawInflate;\n    IO::Uncompress::RawInflate::rawinflate(\\$data, \\my $uncompressed)\n      or die \"rawinflate failed: $IO::Uncompress::RawInflate::RawInflateError\\n\";\n\n    warn sprintf(\"Uncompressed data size: %s bytes\\n\", length($uncompressed));\n\n    return $uncompressed;\n}\n\nsub help ($exit_code = 0) {\n    print <<\"EOT\";\nusage: $0 [options] [input] [output]\n\noptions:\n\n    -z [file] : encode a given data file\n\nexample:\n\n    # Encode\n    perl $0 -z=data.txt input.jpg encoded.png\n\n    # Decode\n    perl $0 encoded.png decoded-data.txt\nEOT\n\n    exit($exit_code);\n}\n\nmy $data_file;\n\nGetOptions(\"z|f|encode=s\" => \\$data_file,\n           \"h|help\"       => sub { help(0) },)\n  or die(\"Error in command line arguments\\n\");\n\nif (defined($data_file)) {\n\n    my $input_image  = shift(@ARGV) // help(2);\n    my $output_image = shift(@ARGV);\n\n    open my $fh, '<:raw', $data_file\n      or die \"Can't open file <<$data_file>> for reading: $!\";\n\n    my $data = do {\n        local $/;\n        <$fh>;\n    };\n\n    close $fh;\n\n    my $img = encode_data($data, $input_image);\n\n    if (defined($output_image)) {\n\n        if ($output_image !~ /\\.png\\z/i) {\n            die \"The output image must have the '.png' extension!\\n\";\n        }\n\n        $img->write(file => $output_image)\n          or die $img->errstr;\n    }\n    else {\n        $img->write(fh => \\*STDOUT, type => 'png')\n          or die $img->errstr;\n    }\n}\nelse {\n    my $input_image = shift(@ARGV) // help(2);\n    my $output_file = shift(@ARGV);\n\n    my $data = decode_data($input_image);\n\n    if (defined($output_file)) {\n        open my $fh, '>:raw', $output_file\n          or die \"Can't open file <<$output_file>> for writing: $!\";\n        print $fh $data;\n        close $fh;\n    }\n    else {\n        print $data;\n    }\n}\n"
  },
  {
    "path": "Image/outguess-png.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 06 February 2022\n# Edit: 31 July 2022\n# https://github.com/trizen\n\n# Hide arbitrary data into the pixels of a PNG image, storing 3 bits in each pixel color.\n\n# Concept inspired by outguess:\n#   https://github.com/resurrecting-open-source-projects/outguess\n#   https://uncovering-cicada.fandom.com/wiki/OutGuess\n\n# Q: How does it work?\n# A: The script uses the GD library to read the RGB color values of each pixel.\n#    Then it changes the last bit of each value to one bit from the data to be encoded.\n\n# Q: How does the decoding work?\n# A: The first 32 bits from the first 32 pixels of the image, form the length of the encoded data.\n#    Then the remaining bits (3 bits from each pixel) are collected to form the encoded data.\n\n# The script also does transparent Deflate compression and decompression of the encoded data.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nno warnings 'once';\n\nuse GD           qw();\nuse Getopt::Long qw(GetOptions);\nuse experimental qw(signatures);\n\nGD::Image->trueColor(1);\n\nbinmode(STDIN,  ':raw');\nbinmode(STDOUT, ':raw');\n\nsub encode_data ($data, $img_file) {\n\n    my $image = GD::Image->new($img_file)\n      or die \"Can't open image <<$img_file>>: $!\";\n\n    $image = $image->newFromJpegData($image->jpeg(100));\n\n    require IO::Compress::RawDeflate;\n    IO::Compress::RawDeflate::rawdeflate(\\$data, \\my $compressed_data)\n      or die \"rawdeflate failed: $IO::Compress::RawDeflate::RawDeflateError\\n\";\n\n    $data = $compressed_data;\n\n    my $bin = unpack(\"B*\", $data);\n    my ($width, $height) = $image->getBounds();\n\n    my $maximum_data_size = 3 * (($width * $height - 32) >> 3);\n    my $data_size         = length($bin) >> 3;\n\n    if ($data_size == 0) {\n        die sprintf(\"No data was given!\\n\");\n    }\n\n    if ($data_size > $maximum_data_size) {\n        die sprintf(\n                    \"Data is too large (%s bytes) for this image (exceeded by %.2f%%).\\n\"\n                      . \"Maximum data size for this image is %s bytes.\\n\",\n                    $data_size, 100 - ($maximum_data_size / $data_size * 100),\n                    $maximum_data_size\n                   );\n    }\n\n    warn sprintf(\"Compressed data size: %s bytes (%.2f%% out of max %s bytes)\\n\",\n                 $data_size, $data_size / $maximum_data_size * 100,\n                 $maximum_data_size);\n\n    my $length_bin = unpack(\"B*\", pack(\"N*\", $data_size));\n\n    $bin = reverse($length_bin . $bin);\n\n    my $size = length($bin);\n\n  OUTER: foreach my $y (0 .. $height - 1) {\n        foreach my $x (0 .. $width - 1) {\n\n            my $index = $image->getPixel($x, $y);\n\n            if ($size > 0) {\n                my ($red, $green, $blue) = $image->rgb($index);\n                $index = $image->colorResolve(map { (($_ >> 1) << 1) | (chop($bin) || 0) } ($red, $green, $blue));\n                $size -= 3;\n            }\n            else {\n                last OUTER;\n            }\n\n            $image->setPixel($x, $y, $index);\n        }\n    }\n\n    return $image;\n}\n\nsub decode_data ($img_file) {\n\n    my $image = GD::Image->new($img_file)\n      or die \"Can't open image <<$img_file>>: $!\";\n\n    my ($width, $height) = $image->getBounds();\n\n    my $bin  = '';\n    my $size = 0;\n\n    my $length        = $width * $height;\n    my $find_length   = 1;\n    my $max_data_size = 3 * ($length - 4);\n\n  OUTER: foreach my $y (0 .. $height - 1) {\n        foreach my $x (0 .. $width - 1) {\n            my $index = $image->getPixel($x, $y);\n\n            if ($size < $length) {\n\n                my ($red, $green, $blue) = $image->rgb($index);\n\n                $bin .= join('', map { $_ & 1 } ($red, $green, $blue));\n                $size += 3;\n\n                if ($find_length and $size >= 32) {\n\n                    $length      = unpack(\"N*\", pack(\"B*\", substr($bin, 0, 32)));\n                    $find_length = 0;\n                    $size        = length($bin) - 32;\n                    $bin         = substr($bin, 32);\n\n                    if ($length > $max_data_size or $length == 0) {\n                        die \"No hidden data was found in this image!\\n\";\n                    }\n\n                    warn sprintf(\"Compressed data size: %s bytes\\n\", $length);\n                    $length <<= 3;\n                }\n            }\n            else {\n                last OUTER;\n            }\n        }\n    }\n\n    my $data = pack(\"B*\", substr($bin, 0, $length));\n\n    require IO::Uncompress::RawInflate;\n    IO::Uncompress::RawInflate::rawinflate(\\$data, \\my $uncompressed)\n      or die \"rawinflate failed: $IO::Uncompress::RawInflate::RawInflateError\\n\";\n\n    warn sprintf(\"Uncompressed data size: %s bytes\\n\", length($uncompressed));\n\n    return $uncompressed;\n}\n\nsub help ($exit_code = 0) {\n    print <<\"EOT\";\nusage: $0 [options] [input] [output]\n\noptions:\n\n    -z [file] : encode a given data file\n\nexample:\n\n    # Encode\n    perl $0 -z=data.txt input.jpg encoded.png\n\n    # Decode\n    perl $0 encoded.png decoded-data.txt\nEOT\n\n    exit($exit_code);\n}\n\nmy $data_file;\n\nGetOptions(\"z|f|encode=s\" => \\$data_file,\n           \"h|help\"       => sub { help(0) },)\n  or die(\"Error in command line arguments\\n\");\n\nif (defined($data_file)) {\n\n    my $input_image  = shift(@ARGV) // help(2);\n    my $output_image = shift(@ARGV);\n\n    open my $fh, '<:raw', $data_file\n      or die \"Can't open file <<$data_file>> for reading: $!\";\n\n    my $data = do {\n        local $/;\n        <$fh>;\n    };\n\n    close $fh;\n\n    my $img = encode_data($data, $input_image);\n\n    if (defined($output_image)) {\n\n        if ($output_image !~ /\\.png\\z/i) {\n            die \"The output image must have the '.png' extension!\\n\";\n        }\n\n        open my $fh, '>:raw', $output_image\n          or die \"Can't open file <<$output_image>> for writing: $!\";\n        print $fh $img->png(9);\n        close $fh;\n    }\n    else {\n        print $img->png(9);\n    }\n}\nelse {\n    my $input_image = shift(@ARGV) // help(2);\n    my $output_file = shift(@ARGV);\n\n    my $data = decode_data($input_image);\n\n    if (defined($output_file)) {\n        open my $fh, '>:raw', $output_file\n          or die \"Can't open file <<$output_file>> for writing: $!\";\n        print $fh $data;\n        close $fh;\n    }\n    else {\n        print $data;\n    }\n}\n"
  },
  {
    "path": "Image/photo_mosaic_from_images.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 06 January 2017\n# https://github.com/trizen\n\n# A simple RGB mosaic generator from a collection of images, using the pattern from a given image.\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse GD qw();\nuse POSIX qw(ceil);\nuse List::Util qw(min);\nuse File::Find qw(find);\nuse Getopt::Long qw(GetOptions);\n\nGD::Image->trueColor(1);\n\nmy $size        = 15;\nmy $wcrop       = 1 / 2;          # width crop ratio\nmy $hcrop       = 1 / 6;          # height crop ratio\nmy $output_file = 'mosaic.png';\n\nsub usage {\n    my ($code) = @_;\n    print <<\"EOT\";\nusage: $0 [options] [main_image] [photos_dir]\n\noptions:\n    --size=i   : the size of a mosaic square (default: $size)\n    --wcrop=f  : width cropping ratio (default: $wcrop)\n    --hcrop=f  : height cropping ratio (default: $hcrop)\n    --output=s : output filename (default: $output_file)\n\nexample:\n    perl $0 --size=20 main.jpg images\nEOT\n    exit($code);\n}\n\nGetOptions(\n           'size=i'   => \\$size,\n           'wcrop=f'  => \\$wcrop,\n           'hcrop=f'  => \\$hcrop,\n           'output=s' => \\$output_file,\n           'h|help'   => sub { usage(0) },\n          )\n  or die(\"$0: error in command line arguments\\n\");\n\nsub analyze_image {\n    my ($file, $images) = @_;\n\n    my $img = eval { GD::Image->new($file) } || return;\n\n    say \"Analyzing: $file\";\n\n    $img = resize_image($img);\n    my ($width, $height) = $img->getBounds;\n\n    my $red_avg   = 0;\n    my $green_avg = 0;\n    my $blue_avg  = 0;\n    my $avg       = 0;\n\n    my $pixels = $width * $height;\n    foreach my $y (0 .. $height - 1) {\n        foreach my $x (0 .. $width - 1) {\n            my $pixel = $img->getPixel($x, $y);\n            my ($red, $green, $blue) = $img->rgb($pixel);\n\n            $avg       += ($red + $green + $blue) / 3 / $pixels;\n            $red_avg   += $red / $pixels;\n            $green_avg += $green / $pixels;\n            $blue_avg  += $blue / $pixels;\n        }\n    }\n\n    my ($x, $y, $z) = map { ($_ + $avg) / 2 } ($red_avg, $green_avg, $blue_avg);\n    push @{$images->[$x][$y][$z]}, $img;\n}\n\nsub resize_image {\n    my ($image) = @_;\n\n    # Get image dimensions\n    my ($width, $height) = $image->getBounds();\n\n    # File is already at the wanted resolution\n    if ($width == $size and $height == $size) {\n        return $image;\n    }\n\n    # Get the minimum ratio\n    my $min_r = min($width / $size, $height / $size);\n\n    my $n_width  = sprintf('%.0f', $width / $min_r);\n    my $n_height = sprintf('%.0f', $height / $min_r);\n\n    # Create a new GD image with the new dimensions\n    my $gd = GD::Image->new($n_width, $n_height);\n    $gd->copyResampled($image, 0, 0, 0, 0, $n_width, $n_height, $width, $height);\n\n    # Create a new GD image with the wanted dimensions\n    my $cropped = GD::Image->new($size, $size);\n\n    # Crop from left and right\n    if ($n_width > $size) {\n        my $diff = $n_width - $size;\n        my $left = ceil($diff * $wcrop);\n        $cropped->copy($gd, 0, 0, $left, 0, $size, $size);\n    }\n\n    # Crop from top and bottom\n    elsif ($n_height > $size) {\n        my $diff = $n_height - $size;\n        my $top  = int($diff * $hcrop);\n        $cropped->copy($gd, 0, 0, 0, $top, $size, $size);\n    }\n\n    # No crop needed\n    else {\n        $cropped = $gd;\n    }\n\n    return $cropped;\n}\n\nsub find_closest {\n    my ($red, $green, $blue, $images) = @_;\n\n    my ($R, $G, $B);\n\n    # Finds the closest red value\n    for (my $j = 0 ; ; ++$j) {\n        if (exists($images->[$red + $j]) and defined($images->[$red + $j])) {\n            $R = $images->[$red + $j];\n            last;\n        }\n\n        if ($red - $j >= 0 and defined($images->[$red - $j])) {\n            $R = $images->[$red - $j];\n            last;\n        }\n    }\n\n    # Finds the closest green value\n    for (my $j = 0 ; ; ++$j) {\n        if (exists($R->[$green + $j]) and defined($R->[$green + $j])) {\n            $G = $R->[$green + $j];\n            last;\n        }\n\n        if ($green - $j >= 0 and defined($R->[$green - $j])) {\n            $G = $R->[$green - $j];\n            last;\n        }\n    }\n\n    # Finds the closest blue value\n    for (my $j = 0 ; ; ++$j) {\n        if (exists($G->[$blue + $j]) and defined($G->[$blue + $j])) {\n            $B = $G->[$blue + $j];\n            last;\n        }\n\n        if ($blue - $j >= 0 and defined($G->[$blue - $j])) {\n            $B = $G->[$blue - $j];\n            last;\n        }\n    }\n\n    $B->[rand @$B];    # returns a random image (when there are more candidates)\n}\n\nmy $main_file = shift(@ARGV) // usage(2);\nmy @photo_dirs = (@ARGV ? @ARGV : usage(2));\n\nmy $img = GD::Image->new($main_file) || die \"Can't load image `$main_file`: $!\";\n\nif ($size <= 0) {\n    die \"$0: size must be greater than zero (got: $size)\\n\";\n}\n\nmy @images;    # stores all the image objects\n\nfind {\n    no_chdir => 1,\n    wanted   => sub {\n        if (/\\.(?:jpe?g|png)\\z/i) {\n            analyze_image($_, \\@images);\n        }\n    },\n} => @photo_dirs;\n\nmy ($width, $height) = $img->getBounds;\nmy $mosaic = GD::Image->new($width, $height);\n\nforeach my $y (0 .. $height / $size) {\n    foreach my $x (0 .. $width / $size) {\n        $mosaic->copy(find_closest($img->rgb($img->getPixel($x * $size, $y * $size)), \\@images),\n                      $x * $size, $y * $size, 0, 0, $size, $size);\n    }\n}\n\nopen my $fh, '>:raw', $output_file;\nprint $fh (\n             $output_file =~ /\\.png\\z/i\n           ? $mosaic->png\n           : $mosaic->jpeg\n          );\nclose $fh;\n"
  },
  {
    "path": "Image/qhi_decoder.pl",
    "content": "#!/usr/bin/perl\n\n# Implementation of the QHI decoder (QOI+Huffman coding), generating a PNG file.\n\n# See also:\n#   https://qoiformat.org/\n#   https://github.com/phoboslab/qoi\n\nuse 5.020;\nuse warnings;\n\nuse Imager;\nuse experimental qw(signatures);\n\nsub huffman_decode ($bits, $hash) {\n    local $\" = '|';\n    $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1}/gr;    # very fast\n}\n\nsub qhi_decoder ($bytes) {\n\n    my sub invalid() {\n        die \"Not a QHIF image\";\n    }\n\n    my $index = 0;\n\n    join('', map { $bytes->[$index++] } 1 .. 4) eq 'qhif' or invalid();\n\n    my $width  = unpack('N', join('', map { $bytes->[$index++] } 1 .. 4));\n    my $height = unpack('N', join('', map { $bytes->[$index++] } 1 .. 4));\n\n    my $channels   = ord $bytes->[$index++];\n    my $colorspace = ord $bytes->[$index++];\n\n    ($width > 0 and $height > 0) or invalid();\n    ($channels > 0 and $channels <= 4) or invalid();\n    ($colorspace == 0 or $colorspace == 1) or invalid();\n\n    ord(pop(@$bytes)) == 0x01 or invalid();\n\n    for (1 .. 7) {\n        ord(pop(@$bytes)) == 0x00 or invalid();\n    }\n\n    say \"[$width, $height, $channels, $colorspace]\";\n\n    my $img = 'Imager'->new(\n                            xsize    => $width,\n                            ysize    => $height,\n                            channels => $channels,\n                           );\n\n    my $run = 0;\n    my @px  = (0, 0, 0, 255);\n\n    my @pixels;\n    my @colors = (map { [0, 0, 0, 0] } 1 .. 64);\n\n    my @codes;\n    my $codes_len = 0;\n\n    foreach my $c (0 .. 255) {\n        my $l = ord($bytes->[$index++]);\n        if ($l > 0) {\n            $codes_len += $l;\n            push @codes, [$c, $l];\n        }\n    }\n\n    my $codes_bin = '';\n    while (length($codes_bin) < $codes_len) {\n        $codes_bin .= unpack('B*', $bytes->[$index++] // last);\n    }\n\n    my %rev_dict;\n    foreach my $pair (@codes) {\n        my $code = substr($codes_bin, 0, $pair->[1], '');\n        $rev_dict{$code} = chr($pair->[0]);\n    }\n\n    my $enc_len = unpack('N', join('', map { $bytes->[$index++] } 1 .. 4));\n\n    splice(@$bytes, 0, $index);\n\n    if ($enc_len > 0) {\n        @$bytes = unpack(\"C*\", huffman_decode(unpack(\"B\" . $enc_len, join('', @$bytes)), \\%rev_dict));\n    }\n    else {\n        @$bytes = ();\n    }\n\n    $index  = 0;\n\n    while (1) {\n\n        if ($run > 0) {\n            --$run;\n        }\n        else {\n            my $byte = $bytes->[$index++] // last;\n\n            if ($byte == 0b11_11_11_10) {    # OP RGB\n                $px[0] = $bytes->[$index++];\n                $px[1] = $bytes->[$index++];\n                $px[2] = $bytes->[$index++];\n            }\n            elsif ($byte == 0b11_11_11_11) {    # OP RGBA\n                $px[0] = $bytes->[$index++];\n                $px[1] = $bytes->[$index++];\n                $px[2] = $bytes->[$index++];\n                $px[3] = $bytes->[$index++];\n            }\n            elsif (($byte >> 6) == 0b00) {      # OP INDEX\n                @px = @{$colors[$byte]};\n            }\n            elsif (($byte >> 6) == 0b01) {      # OP DIFF\n                my $dr = (($byte & 0b00_11_00_00) >> 4) - 2;\n                my $dg = (($byte & 0b00_00_11_00) >> 2) - 2;\n                my $db = (($byte & 0b00_00_00_11) >> 0) - 2;\n\n                ($px[0] += $dr) %= 256;\n                ($px[1] += $dg) %= 256;\n                ($px[2] += $db) %= 256;\n            }\n            elsif (($byte >> 6) == 0b10) {      # OP LUMA\n                my $byte2 = $bytes->[$index++];\n\n                my $dg    = ($byte & 0b00_111_111) - 32;\n                my $dr_dg = ($byte2 >> 4) - 8;\n                my $db_dg = ($byte2 & 0b0000_1111) - 8;\n\n                my $dr = $dr_dg + $dg;\n                my $db = $db_dg + $dg;\n\n                ($px[0] += $dr) %= 256;\n                ($px[1] += $dg) %= 256;\n                ($px[2] += $db) %= 256;\n            }\n            elsif (($byte >> 6) == 0b11) {    # OP RUN\n                $run = ($byte & 0b00_111_111);\n            }\n\n            $colors[($px[0] * 3 + $px[1] * 5 + $px[2] * 7 + $px[3] * 11) % 64] = [@px];\n        }\n\n        push @pixels, @px;\n    }\n\n    foreach my $row (0 .. $height - 1) {\n        my @line = splice(@pixels, 0, 4 * $width);\n        $img->setscanline(y => $row, pixels => pack(\"C*\", @line));\n    }\n\n    return $img;\n}\n\n@ARGV || do {\n    say STDERR \"usage: $0 [input.qhi] [output.png]\";\n    exit(2);\n};\n\nmy $in_file  = $ARGV[0];\nmy $out_file = $ARGV[1] // \"$in_file.png\";\n\nmy @chars = do {\n    open(my $fh, '<:raw', $in_file)\n      or die \"Can't open file <<$in_file>> for reading: $!\";\n    local $/;\n    split(//, scalar <$fh>);\n};\n\nmy $img = qhi_decoder(\\@chars);\n$img->write(file => $out_file, type => 'png');\n"
  },
  {
    "path": "Image/qhi_encoder.pl",
    "content": "#!/usr/bin/perl\n\n# Variation of the QOI encoder, combined with Huffman coding.\n\n# QHIf = Quite Huffman Image format. :)\n\n# See also:\n#   https://qoiformat.org/\n#   https://github.com/phoboslab/qoi\n\nuse 5.020;\nuse warnings;\n\nuse Imager;\nuse experimental qw(signatures);\n\n# produce encode and decode dictionary from a tree\nsub walk ($node, $code, $h, $rev_h) {\n\n    my $c = $node->[0] // return ($h, $rev_h);\n    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }\n    else        { $h->{$c} = $code; $rev_h->{$code} = $c }\n\n    return ($h, $rev_h);\n}\n\n# make a tree, and return resulting dictionaries\nsub mktree ($bytes) {\n    my (%freq, @nodes);\n\n    ++$freq{$_} for @$bytes;\n    @nodes = map { [$_, $freq{$_}] } sort { $a <=> $b } keys %freq;\n\n    do {    # poor man's priority queue\n        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;\n        my ($x, $y) = splice(@nodes, 0, 2);\n        if (defined($x) and defined($y)) {\n            push @nodes, [[$x, $y], $x->[1] + $y->[1]];\n        }\n    } while (@nodes > 1);\n\n    walk($nodes[0], '', {}, {});\n}\n\nsub huffman_encode ($bytes, $dict) {\n    my $enc = '';\n    for (@$bytes) {\n        $enc .= $dict->{$_} // die \"bad char: $_\";\n    }\n    return $enc;\n}\n\nsub qhi_encoder ($img, $out_fh) {\n\n    use constant {\n                  QOI_OP_RGB  => 0b1111_1110,\n                  QOI_OP_RGBA => 0b1111_1111,\n                  QOI_OP_DIFF => 0b01_000_000,\n                  QOI_OP_RUN  => 0b11_000_000,\n                  QOI_OP_LUMA => 0b10_000_000,\n                 };\n\n    my $width      = $img->getwidth;\n    my $height     = $img->getheight;\n    my $channels   = $img->getchannels;\n    my $colorspace = 0;\n\n    say \"[$width, $height, $channels, $colorspace]\";\n\n    my @header = unpack('C*', 'qhif');\n\n    push @header, unpack('C4', pack('N', $width));\n    push @header, unpack('C4', pack('N', $height));\n\n    push @header, $channels;\n    push @header, $colorspace;\n\n    my @bytes;\n\n    my $run     = 0;\n    my @px      = (0, 0, 0, 255);\n    my @prev_px = @px;\n\n    my @colors = (map { [0, 0, 0, 0] } 1 .. 64);\n\n    foreach my $y (0 .. $height - 1) {\n\n        my @line     = unpack('C*', scalar $img->getscanline(y => $y));\n        my $line_len = scalar(@line);\n\n        for (my $i = 0 ; $i < $line_len ; $i += 4) {\n            @px = splice(@line, 0, 4);\n\n            if (    $px[0] == $prev_px[0]\n                and $px[1] == $prev_px[1]\n                and $px[2] == $prev_px[2]\n                and $px[3] == $prev_px[3]) {\n\n                if (++$run == 62) {\n                    push @bytes, QOI_OP_RUN | ($run - 1);\n                    $run = 0;\n                }\n            }\n            else {\n\n                if ($run > 0) {\n                    push @bytes, (QOI_OP_RUN | ($run - 1));\n                    $run = 0;\n                }\n\n                my $hash     = ($px[0] * 3 + $px[1] * 5 + $px[2] * 7 + $px[3] * 11) % 64;\n                my $index_px = $colors[$hash];\n\n                if (    $px[0] == $index_px->[0]\n                    and $px[1] == $index_px->[1]\n                    and $px[2] == $index_px->[2]\n                    and $px[3] == $index_px->[3]) {    # OP INDEX\n                    push @bytes, $hash;\n                }\n                else {\n\n                    $colors[$hash] = [@px];\n\n                    if ($px[3] == $prev_px[3]) {\n\n                        my $vr = $px[0] - $prev_px[0];\n                        my $vg = $px[1] - $prev_px[1];\n                        my $vb = $px[2] - $prev_px[2];\n\n                        my $vg_r = $vr - $vg;\n                        my $vg_b = $vb - $vg;\n\n                        if (    $vr > -3\n                            and $vr < 2\n                            and $vg > -3\n                            and $vg < 2\n                            and $vb > -3\n                            and $vb < 2) {\n                            push(@bytes, QOI_OP_DIFF | (($vr + 2) << 4) | (($vg + 2) << 2) | ($vb + 2));\n                        }\n                        elsif (    $vg_r > -9\n                               and $vg_r < 8\n                               and $vg > -33\n                               and $vg < 32\n                               and $vg_b > -9\n                               and $vg_b < 8) {\n                            push(@bytes, QOI_OP_LUMA | ($vg + 32));\n                            push(@bytes, (($vg_r + 8) << 4) | ($vg_b + 8));\n                        }\n                        else {\n                            push(@bytes, QOI_OP_RGB, $px[0], $px[1], $px[2]);\n                        }\n                    }\n                    else {\n                        push(@bytes, QOI_OP_RGBA, $px[0], $px[1], $px[2], $px[3]);\n                    }\n                }\n            }\n\n            @prev_px = @px;\n        }\n    }\n\n    if ($run > 0) {\n        push(@bytes, 0b11_00_00_00 | ($run - 1));\n    }\n\n    my @footer;\n    push(@footer, (0x00) x 7);\n    push(@footer, 0x01);\n\n    my ($h, $rev_h) = mktree(\\@bytes);\n    my $enc   = huffman_encode(\\@bytes, $h);\n\n    my $dict  = '';\n    my $codes = '';\n\n    foreach my $i (0 .. 255) {\n        my $c = $h->{$i} // '';\n        $codes .= $c;\n        $dict  .= chr(length($c));\n    }\n\n    # Header\n    print $out_fh pack('C*', @header);\n\n    # Huffman dictionary + data\n    print $out_fh $dict;\n    print $out_fh pack(\"B*\", $codes);\n    print $out_fh pack(\"N\",  length($enc));\n    print $out_fh pack(\"B*\", $enc);\n\n    # Footer\n    print $out_fh pack('C*', @footer);\n}\n\n@ARGV || do {\n    say STDERR \"usage: $0 [input.png] [output.qhi]\";\n    exit(2);\n};\n\nmy $in_file  = $ARGV[0];\nmy $out_file = $ARGV[1] // \"$in_file.qhi\";\n\nmy $img = 'Imager'->new(file => $in_file)\n    or die \"Can't read image: $in_file\";\n\nopen(my $out_fh, '>:raw', $out_file)\n  or die \"Can't open file <<$out_file>> for writing: $!\";\n\nqhi_encoder($img, $out_fh);\n"
  },
  {
    "path": "Image/qoi_decoder.pl",
    "content": "#!/usr/bin/perl\n\n# Implementation of the QOI decoder (generating a PNG file).\n\n# See also:\n#   https://qoiformat.org/\n#   https://github.com/phoboslab/qoi\n#   https://yewtu.be/watch?v=EFUYNoFRHQI\n\nuse 5.020;\nuse warnings;\n\nuse Imager;\nuse experimental qw(signatures);\n\nsub qoi_decoder ($bytes) {\n\n    my sub invalid() {\n        die \"Not a QOIF image\";\n    }\n\n    my $index = 0;\n\n    pack('C4', map { $bytes->[$index++] } 1 .. 4) eq 'qoif' or invalid();\n\n    my $width  = unpack('N', pack('C4', map { $bytes->[$index++] } 1 .. 4));\n    my $height = unpack('N', pack('C4', map { $bytes->[$index++] } 1 .. 4));\n\n    my $channels   = $bytes->[$index++];\n    my $colorspace = $bytes->[$index++];\n\n    ($width > 0 and $height > 0) or invalid();\n    ($channels > 0 and $channels <= 4) or invalid();\n    ($colorspace == 0 or $colorspace == 1) or invalid();\n\n    pop(@$bytes) == 0x01 or invalid();\n\n    for (1 .. 7) {\n        pop(@$bytes) == 0x00 or invalid();\n    }\n\n    say \"[$width, $height, $channels, $colorspace]\";\n\n    my $img = 'Imager'->new(\n                            xsize    => $width,\n                            ysize    => $height,\n                            channels => $channels,\n                           );\n\n    my $run = 0;\n    my @px  = (0, 0, 0, 255);\n\n    my @pixels;\n    my @colors = (map { [0, 0, 0, 0] } 1 .. 64);\n\n    while (1) {\n\n        if ($run > 0) {\n            --$run;\n        }\n        else {\n            my $byte = $bytes->[$index++] // last;\n\n            if ($byte == 0b11_11_11_10) {    # OP RGB\n                $px[0] = $bytes->[$index++];\n                $px[1] = $bytes->[$index++];\n                $px[2] = $bytes->[$index++];\n            }\n            elsif ($byte == 0b11_11_11_11) {    # OP RGBA\n                $px[0] = $bytes->[$index++];\n                $px[1] = $bytes->[$index++];\n                $px[2] = $bytes->[$index++];\n                $px[3] = $bytes->[$index++];\n            }\n            elsif (($byte >> 6) == 0b00) {      # OP INDEX\n                @px = @{$colors[$byte]};\n            }\n            elsif (($byte >> 6) == 0b01) {      # OP DIFF\n                my $dr = (($byte & 0b00_11_00_00) >> 4) - 2;\n                my $dg = (($byte & 0b00_00_11_00) >> 2) - 2;\n                my $db = (($byte & 0b00_00_00_11) >> 0) - 2;\n\n                ($px[0] += $dr) %= 256;\n                ($px[1] += $dg) %= 256;\n                ($px[2] += $db) %= 256;\n            }\n            elsif (($byte >> 6) == 0b10) {      # OP LUMA\n                my $byte2 = $bytes->[$index++];\n\n                my $dg    = ($byte & 0b00_111_111) - 32;\n                my $dr_dg = ($byte2 >> 4) - 8;\n                my $db_dg = ($byte2 & 0b0000_1111) - 8;\n\n                my $dr = $dr_dg + $dg;\n                my $db = $db_dg + $dg;\n\n                ($px[0] += $dr) %= 256;\n                ($px[1] += $dg) %= 256;\n                ($px[2] += $db) %= 256;\n            }\n            elsif (($byte >> 6) == 0b11) {    # OP RUN\n                $run = ($byte & 0b00_111_111);\n            }\n\n            $colors[($px[0] * 3 + $px[1] * 5 + $px[2] * 7 + $px[3] * 11) % 64] = [@px];\n        }\n\n        push @pixels, @px;\n    }\n\n    foreach my $row (0 .. $height - 1) {\n        my @line = splice(@pixels, 0, 4 * $width);\n        $img->setscanline(y => $row, pixels => pack(\"C*\", @line));\n    }\n\n    return $img;\n}\n\n@ARGV || do {\n    say STDERR \"usage: $0 [input.qoi] [output.png]\";\n    exit(2);\n};\n\nmy $in_file  = $ARGV[0];\nmy $out_file = $ARGV[1] // \"$in_file.png\";\n\nmy @bytes = do {\n    open(my $fh, '<:raw', $in_file)\n      or die \"Can't open file <<$in_file>> for reading: $!\";\n    local $/;\n    unpack(\"C*\", scalar <$fh>);\n};\n\nmy $img = qoi_decoder(\\@bytes);\n$img->write(file => $out_file, type => 'png');\n"
  },
  {
    "path": "Image/qoi_encoder.pl",
    "content": "#!/usr/bin/perl\n\n# Implementation of the QOI encoder.\n\n# See also:\n#   https://qoiformat.org/\n#   https://github.com/phoboslab/qoi\n#   https://yewtu.be/watch?v=EFUYNoFRHQI\n\nuse 5.020;\nuse warnings;\n\nuse Imager;\nuse experimental qw(signatures);\n\nsub qoi_encoder ($img) {\n\n    use constant {\n                  QOI_OP_RGB  => 0b1111_1110,\n                  QOI_OP_RGBA => 0b1111_1111,\n                  QOI_OP_DIFF => 0b01_000_000,\n                  QOI_OP_RUN  => 0b11_000_000,\n                  QOI_OP_LUMA => 0b10_000_000,\n                 };\n\n    my $width      = $img->getwidth;\n    my $height     = $img->getheight;\n    my $channels   = $img->getchannels;\n    my $colorspace = 0;\n\n    say \"[$width, $height, $channels, $colorspace]\";\n\n    my @bytes = unpack('C*', 'qoif');\n\n    push @bytes, unpack('C4', pack('N', $width));\n    push @bytes, unpack('C4', pack('N', $height));\n\n    push @bytes, $channels;\n    push @bytes, $colorspace;\n\n    my $run     = 0;\n    my @px      = (0, 0, 0, 255);\n    my @prev_px = @px;\n\n    my @colors = (map { [0, 0, 0, 0] } 1 .. 64);\n\n    foreach my $y (0 .. $height - 1) {\n\n        my @line     = unpack('C*', scalar $img->getscanline(y => $y));\n        my $line_len = scalar(@line);\n\n        for (my $i = 0 ; $i < $line_len ; $i += 4) {\n            @px = splice(@line, 0, 4);\n\n            if (    $px[0] == $prev_px[0]\n                and $px[1] == $prev_px[1]\n                and $px[2] == $prev_px[2]\n                and $px[3] == $prev_px[3]) {\n\n                if (++$run == 62) {\n                    push @bytes, QOI_OP_RUN | ($run - 1);\n                    $run = 0;\n                }\n            }\n            else {\n\n                if ($run > 0) {\n                    push @bytes, (QOI_OP_RUN | ($run - 1));\n                    $run = 0;\n                }\n\n                my $hash     = ($px[0] * 3 + $px[1] * 5 + $px[2] * 7 + $px[3] * 11) % 64;\n                my $index_px = $colors[$hash];\n\n                if (    $px[0] == $index_px->[0]\n                    and $px[1] == $index_px->[1]\n                    and $px[2] == $index_px->[2]\n                    and $px[3] == $index_px->[3]) {    # OP INDEX\n                    push @bytes, $hash;\n                }\n                else {\n\n                    $colors[$hash] = [@px];\n\n                    if ($px[3] == $prev_px[3]) {\n\n                        my $vr = $px[0] - $prev_px[0];\n                        my $vg = $px[1] - $prev_px[1];\n                        my $vb = $px[2] - $prev_px[2];\n\n                        my $vg_r = $vr - $vg;\n                        my $vg_b = $vb - $vg;\n\n                        if (    $vr > -3\n                            and $vr < 2\n                            and $vg > -3\n                            and $vg < 2\n                            and $vb > -3\n                            and $vb < 2) {\n                            push(@bytes, QOI_OP_DIFF | (($vr + 2) << 4) | (($vg + 2) << 2) | ($vb + 2));\n                        }\n                        elsif (    $vg_r > -9\n                               and $vg_r < 8\n                               and $vg > -33\n                               and $vg < 32\n                               and $vg_b > -9\n                               and $vg_b < 8) {\n                            push(@bytes, QOI_OP_LUMA | ($vg + 32));\n                            push(@bytes, (($vg_r + 8) << 4) | ($vg_b + 8));\n                        }\n                        else {\n                            push(@bytes, QOI_OP_RGB, $px[0], $px[1], $px[2]);\n                        }\n                    }\n                    else {\n                        push(@bytes, QOI_OP_RGBA, $px[0], $px[1], $px[2], $px[3]);\n                    }\n                }\n            }\n\n            @prev_px = @px;\n        }\n    }\n\n    if ($run > 0) {\n        push(@bytes, QOI_OP_RUN | ($run - 1));\n    }\n\n    push(@bytes, (0x00) x 7);\n    push(@bytes, 0x01);\n\n    return \\@bytes;\n}\n\n@ARGV || do {\n    say STDERR \"usage: $0 [input.png] [output.qoi]\";\n    exit(2);\n};\n\nmy $in_file  = $ARGV[0];\nmy $out_file = $ARGV[1] // \"$in_file.qoi\";\n\nmy $img = 'Imager'->new(file => $in_file)\n    or die \"Can't read image: $in_file\";\n\nmy $bytes = qoi_encoder($img);\n\nopen(my $fh, '>:raw', $out_file)\n  or die \"Can't open file <<$out_file>> for writing: $!\";\n\nprint $fh pack('C*', @$bytes);\nclose $fh;\n"
  },
  {
    "path": "Image/qzst_decoder.pl",
    "content": "#!/usr/bin/perl\n\n# Implementation of the QZST decoder (QOI + Zstandard compression), generating a PNG file.\n\n# See also:\n#   https://qoiformat.org/\n#   https://github.com/phoboslab/qoi\n\nuse 5.020;\nuse warnings;\n\nuse Imager;\nuse experimental           qw(signatures);\nuse IO::Uncompress::UnZstd qw(unzstd $UnZstdError);\n\nsub qzst_decoder ($bytes) {\n\n    my sub invalid() {\n        die \"Not a QZST image\";\n    }\n\n    my $index = 0;\n\n    join('', map { $bytes->[$index++] } 1 .. 4) eq 'qzst' or invalid();\n\n    my $width  = unpack('N', join('', map { $bytes->[$index++] } 1 .. 4));\n    my $height = unpack('N', join('', map { $bytes->[$index++] } 1 .. 4));\n\n    my $channels   = ord $bytes->[$index++];\n    my $colorspace = ord $bytes->[$index++];\n\n    ($width > 0 and $height > 0) or invalid();\n    ($channels > 0 and $channels <= 4) or invalid();\n    ($colorspace == 0 or $colorspace == 1) or invalid();\n\n    ord(pop(@$bytes)) == 0x01 or invalid();\n\n    for (1 .. 7) {\n        ord(pop(@$bytes)) == 0x00 or invalid();\n    }\n\n    say \"[$width, $height, $channels, $colorspace]\";\n\n    my $len = unpack('N', join('', map { $bytes->[$index++] } 1 .. 4));\n\n    scalar(@$bytes) - $index == $len or invalid();\n    splice(@$bytes, 0, $index);\n\n    unzstd(\\join('', @$bytes), \\my $qoi_data)\n      or die \"unzstd failed: $UnZstdError\\n\";\n\n    $index  = 0;\n    @$bytes = unpack('C*', $qoi_data);\n\n    my $img = 'Imager'->new(\n                            xsize    => $width,\n                            ysize    => $height,\n                            channels => $channels,\n                           );\n\n    my $run = 0;\n    my @px  = (0, 0, 0, 255);\n\n    my @pixels;\n    my @colors = (map { [0, 0, 0, 0] } 1 .. 64);\n\n    while (1) {\n\n        if ($run > 0) {\n            --$run;\n        }\n        else {\n            my $byte = $bytes->[$index++] // last;\n\n            if ($byte == 0b11_11_11_10) {    # OP RGB\n                $px[0] = $bytes->[$index++];\n                $px[1] = $bytes->[$index++];\n                $px[2] = $bytes->[$index++];\n            }\n            elsif ($byte == 0b11_11_11_11) {    # OP RGBA\n                $px[0] = $bytes->[$index++];\n                $px[1] = $bytes->[$index++];\n                $px[2] = $bytes->[$index++];\n                $px[3] = $bytes->[$index++];\n            }\n            elsif (($byte >> 6) == 0b00) {      # OP INDEX\n                @px = @{$colors[$byte]};\n            }\n            elsif (($byte >> 6) == 0b01) {      # OP DIFF\n                my $dr = (($byte & 0b00_11_00_00) >> 4) - 2;\n                my $dg = (($byte & 0b00_00_11_00) >> 2) - 2;\n                my $db = (($byte & 0b00_00_00_11) >> 0) - 2;\n\n                ($px[0] += $dr) %= 256;\n                ($px[1] += $dg) %= 256;\n                ($px[2] += $db) %= 256;\n            }\n            elsif (($byte >> 6) == 0b10) {      # OP LUMA\n                my $byte2 = $bytes->[$index++];\n\n                my $dg    = ($byte & 0b00_111_111) - 32;\n                my $dr_dg = ($byte2 >> 4) - 8;\n                my $db_dg = ($byte2 & 0b0000_1111) - 8;\n\n                my $dr = $dr_dg + $dg;\n                my $db = $db_dg + $dg;\n\n                ($px[0] += $dr) %= 256;\n                ($px[1] += $dg) %= 256;\n                ($px[2] += $db) %= 256;\n            }\n            elsif (($byte >> 6) == 0b11) {    # OP RUN\n                $run = ($byte & 0b00_111_111);\n            }\n\n            $colors[($px[0] * 3 + $px[1] * 5 + $px[2] * 7 + $px[3] * 11) % 64] = [@px];\n        }\n\n        push @pixels, @px;\n    }\n\n    foreach my $row (0 .. $height - 1) {\n        my @line = splice(@pixels, 0, 4 * $width);\n        $img->setscanline(y => $row, pixels => pack(\"C*\", @line));\n    }\n\n    return $img;\n}\n\n@ARGV || do {\n    say STDERR \"usage: $0 [input.qzst] [output.png]\";\n    exit(2);\n};\n\nmy $in_file  = $ARGV[0];\nmy $out_file = $ARGV[1] // \"$in_file.png\";\n\nmy @chars = do {\n    open(my $fh, '<:raw', $in_file)\n      or die \"Can't open file <<$in_file>> for reading: $!\";\n    local $/;\n    split(//, scalar <$fh>);\n};\n\nmy $img = qzst_decoder(\\@chars);\n$img->write(file => $out_file, type => 'png');\n"
  },
  {
    "path": "Image/qzst_encoder.pl",
    "content": "#!/usr/bin/perl\n\n# Variation of the QOI encoder, combined with Zstandard compression.\n\n# See also:\n#   https://qoiformat.org/\n#   https://github.com/phoboslab/qoi\n\nuse 5.020;\nuse warnings;\n\nuse Imager;\nuse experimental       qw(signatures);\nuse IO::Compress::Zstd qw(zstd $ZstdError);\n\nsub qzst_encoder ($img, $out_fh) {\n\n    use constant {\n                  QOI_OP_RGB  => 0b1111_1110,\n                  QOI_OP_RGBA => 0b1111_1111,\n                  QOI_OP_DIFF => 0b01_000_000,\n                  QOI_OP_RUN  => 0b11_000_000,\n                  QOI_OP_LUMA => 0b10_000_000,\n                 };\n\n    my $width      = $img->getwidth;\n    my $height     = $img->getheight;\n    my $channels   = $img->getchannels;\n    my $colorspace = 0;\n\n    say \"[$width, $height, $channels, $colorspace]\";\n\n    my @header = unpack('C*', 'qzst');\n\n    push @header, unpack('C4', pack('N', $width));\n    push @header, unpack('C4', pack('N', $height));\n\n    push @header, $channels;\n    push @header, $colorspace;\n\n    my $qoi_data = '';\n\n    my $run     = 0;\n    my @px      = (0, 0, 0, 255);\n    my @prev_px = @px;\n\n    my @colors = (map { [0, 0, 0, 0] } 1 .. 64);\n\n    foreach my $y (0 .. $height - 1) {\n\n        my @line     = unpack('C*', scalar $img->getscanline(y => $y));\n        my $line_len = scalar(@line);\n\n        for (my $i = 0 ; $i < $line_len ; $i += 4) {\n            @px = splice(@line, 0, 4);\n\n            if (    $px[0] == $prev_px[0]\n                and $px[1] == $prev_px[1]\n                and $px[2] == $prev_px[2]\n                and $px[3] == $prev_px[3]) {\n\n                if (++$run == 62) {\n                    $qoi_data .= chr(QOI_OP_RUN | ($run - 1));\n                    $run = 0;\n                }\n            }\n            else {\n\n                if ($run > 0) {\n                    $qoi_data .= chr(QOI_OP_RUN | ($run - 1));\n                    $run = 0;\n                }\n\n                my $hash     = ($px[0] * 3 + $px[1] * 5 + $px[2] * 7 + $px[3] * 11) % 64;\n                my $index_px = $colors[$hash];\n\n                if (    $px[0] == $index_px->[0]\n                    and $px[1] == $index_px->[1]\n                    and $px[2] == $index_px->[2]\n                    and $px[3] == $index_px->[3]) {    # OP INDEX\n                    $qoi_data .= chr($hash);\n                }\n                else {\n\n                    $colors[$hash] = [@px];\n\n                    if ($px[3] == $prev_px[3]) {\n\n                        my $vr = $px[0] - $prev_px[0];\n                        my $vg = $px[1] - $prev_px[1];\n                        my $vb = $px[2] - $prev_px[2];\n\n                        my $vg_r = $vr - $vg;\n                        my $vg_b = $vb - $vg;\n\n                        if (    $vr > -3\n                            and $vr < 2\n                            and $vg > -3\n                            and $vg < 2\n                            and $vb > -3\n                            and $vb < 2) {\n                            $qoi_data .= chr(QOI_OP_DIFF | (($vr + 2) << 4) | (($vg + 2) << 2) | ($vb + 2));\n                        }\n                        elsif (    $vg_r > -9\n                               and $vg_r < 8\n                               and $vg > -33\n                               and $vg < 32\n                               and $vg_b > -9\n                               and $vg_b < 8) {\n                            $qoi_data .= join('', chr(QOI_OP_LUMA | ($vg + 32)), chr((($vg_r + 8) << 4) | ($vg_b + 8)));\n                        }\n                        else {\n                            $qoi_data .= join('', chr(QOI_OP_RGB), chr($px[0]), chr($px[1]), chr($px[2]));\n                        }\n                    }\n                    else {\n                        $qoi_data .= join('', chr(QOI_OP_RGBA), chr($px[0]), chr($px[1]), chr($px[2]), chr($px[3]));\n                    }\n                }\n            }\n\n            @prev_px = @px;\n        }\n    }\n\n    if ($run > 0) {\n        $qoi_data .= chr(0b11_00_00_00 | ($run - 1));\n    }\n\n    my @footer;\n    push(@footer, (0x00) x 7);\n    push(@footer, 0x01);\n\n    # Header\n    print $out_fh pack('C*', @header);\n\n    # Compressed data\n    zstd(\\$qoi_data, \\my $zstd_data) or die \"zstd failed: $ZstdError\\n\";\n    print $out_fh pack(\"N\", length($zstd_data));\n    print $out_fh $zstd_data;\n\n    # Footer\n    print $out_fh pack('C*', @footer);\n}\n\n@ARGV || do {\n    say STDERR \"usage: $0 [input.png] [output.qzst]\";\n    exit(2);\n};\n\nmy $in_file  = $ARGV[0];\nmy $out_file = $ARGV[1] // \"$in_file.qzst\";\n\nmy $img = 'Imager'->new(file => $in_file)\n  or die \"Can't read image: $in_file\";\n\nopen(my $out_fh, '>:raw', $out_file)\n  or die \"Can't open file <<$out_file>> for writing: $!\";\n\nqzst_encoder($img, $out_fh);\n"
  },
  {
    "path": "Image/recompress_images.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 13 September 2023\n# Edit: 08 August 2024\n# https://github.com/trizen\n\n# Recompress a given list of images, using either PNG or JPEG (whichever results in a smaller file size).\n\n# WARNING: the original files are deleted!\n# WARNING: the program does LOSSY compression of images!\n\n# If the file is a PNG image:\n#   1. we create a JPEG copy\n#   2. we recompress the PNG image using `pngquant`\n#   3. we recompress the JPEG copy using `jpegoptim`\n#   4. then we keep whichever is smaller: the PNG or the JPEG file\n\n# If the file is a JPEG image:\n#   1. we create a PNG copy\n#   2. we recompress the JPEG image using `jpegoptim`\n#   3. we recompress the PNG copy using `pngquant`\n#   4. then we keep whichever is smaller: the JPEG or the PNG file\n\n# The following tools are required:\n#   * jpegoptim  -- for recompressing JPEG images\n#   * pngquant   -- for recompressing PNG images\n\nuse 5.036;\n\nuse GD;\nuse File::Find            qw(find);\nuse File::Temp            qw(mktemp);\nuse File::Copy            qw(copy);\nuse File::Spec::Functions qw(catfile tmpdir);\nuse Getopt::Long          qw(GetOptions);\n\nGD::Image->trueColor(1);\n\nmy $png_only  = 0;    # true to recompress only PNG images\nmy $jpeg_only = 0;    # true to recompress only JPEG images\n\nmy $quality         = 85;    # default quality value for JPEG (between 0-100)\nmy $png_compression = 0;     # default PNG compression level for GD (between 0-9)\n\nmy $keep_original = 0;       # true to keep original images\nmy $use_exiftool  = 0;       # true to use `exiftool` instead of `File::MimeInfo::Magic`\nmy $preserve_attr = 0;       # preserve original file attributes\nmy $suffix        = '';      # recompressed filenames suffix\n\nsub png2jpeg (%args) {\n\n    my $orig_file = $args{png_file}  // return;\n    my $jpeg_file = $args{jpeg_file} // return;\n\n    my $image = eval { GD::Image->new($orig_file) } // do {\n        warn \"[!] Can't load file <<$orig_file>>. Skipping...\\n\";\n        return;\n    };\n\n    my $jpeg_data = $image->jpeg($quality);\n\n    open(my $fh, '>:raw', $jpeg_file) or do {\n        warn \"[!] Can't open file <<$jpeg_file>> for writing: $!\\n\";\n        return;\n    };\n\n    print {$fh} $jpeg_data;\n    close $fh;\n}\n\nsub jpeg2png (%args) {\n\n    my $orig_file = $args{jpeg_file} // return;\n    my $png_file  = $args{png_file}  // return;\n\n    my $image = eval { GD::Image->new($orig_file) } // do {\n        warn \"[!] Can't load file <<$orig_file>>. Skipping...\\n\";\n        return;\n    };\n\n    my $png_data = $image->png($png_compression);\n\n    open(my $fh, '>:raw', $png_file) or do {\n        warn \"[!] Can't open file <<$png_file>> for writing: $!\\n\";\n        return;\n    };\n\n    print {$fh} $png_data;\n    close $fh;\n}\n\nsub determine_mime_type ($file) {\n\n    if ($file =~ /\\.jpe?g\\z/i) {\n        return \"image/jpeg\";\n    }\n\n    if ($file =~ /\\.png\\z/i) {\n        return \"image/png\";\n    }\n\n    if ($use_exiftool) {\n        my $res = `exiftool \\Q$file\\E`;\n        $? == 0       or return;\n        defined($res) or return;\n        if ($res =~ m{^MIME\\s+Type\\s*:\\s*(\\S+)}mi) {\n            return $1;\n        }\n        return;\n    }\n\n    require File::MimeInfo::Magic;\n    File::MimeInfo::Magic::magic($file);\n}\n\nsub optimize_jpeg ($jpeg_file) {\n\n    # Uncomment the following line to use `recomp-jpg` from LittleUtils\n    # return system('recomp-jpg', '-q', '-t', $quality, $jpeg_file);\n\n    system('jpegoptim', '-q', '-s', '--threshold=0.1', '-m', $quality, $jpeg_file);\n}\n\nsub optimize_png ($png_file) {\n    system('pngquant', '--strip', '--ext', '.png', '--skip-if-larger', '--force', $png_file);\n}\n\n@ARGV or die <<\"USAGE\";\nusage: perl $0 [options] [dirs | files]\n\nRecompress a given list of images, using either PNG or JPEG (whichever results in a smaller file size).\n\noptions:\n\n    -q INT      : quality level for JPEG (default: $quality)\n    --jpeg      : recompress only JPEG images (default: $jpeg_only)\n    --png       : recompress only PNG images (default: $png_only)\n    --exiftool  : use `exiftool` to determine the MIME type (default: $use_exiftool)\n    --preserve  : preserve original file timestamps and permissions\n    --suffix=s  : add a given suffix to recompressed filenames\n    --keep      : keep original files (to be used with --suffix)\n\nWARNING: the original files are deleted!\nWARNING: the program does LOSSY compression of images!\nUSAGE\n\nGetOptions(\n           'q|quality=i' => \\$quality,\n           'jpeg|jpg!'   => \\$jpeg_only,\n           'png!'        => \\$png_only,\n           'exiftool!'   => \\$use_exiftool,\n           'p|preserve!' => \\$preserve_attr,\n           'suffix=s'    => \\$suffix,\n           'keep!'       => \\$keep_original,\n          )\n  or die \"Error in command-line arguments!\";\n\nmy %types = (\n             'image/png' => {\n                             files  => [],\n                             format => 'png',\n                            },\n             'image/jpeg' => {\n                              files  => [],\n                              format => 'jpg',\n                             },\n            );\n\nfind(\n    {\n     no_chdir => 1,\n     wanted   => sub {\n\n         (-f $_) || return;\n         my $type = determine_mime_type($_) // return;\n\n         if (exists $types{$type}) {\n             my $ref = $types{$type};\n             push @{$ref->{files}}, $_;\n         }\n     }\n    } => @ARGV\n);\n\nmy $total_savings = 0;\n\nmy $temp_png = catfile(tmpdir(), mktemp(\"tmpfileXXXXX\") . '.png');\nmy $temp_jpg = catfile(tmpdir(), mktemp(\"tmpfileXXXXX\") . '.jpg');\n\nsub recompress_image ($file, $file_format) {\n\n    my $conversion_func = \\&jpeg2png;\n    my $temp_file       = $temp_jpg;\n\n    if ($file_format eq 'png') {\n        $conversion_func = \\&png2jpeg;\n        $temp_file       = $temp_png;\n    }\n\n    copy($file, $temp_file) or do {\n        warn \"[!] Can't copy <<$file>> to <<$temp_file>>: $!\\n\";\n        return;\n    };\n\n    $conversion_func->(png_file => $temp_png, jpeg_file => $temp_jpg) or return;\n    optimize_png($temp_png);\n    optimize_jpeg($temp_jpg);\n\n    my $final_file = $temp_png;\n    my $file_ext   = 'png';\n\n    if ((-s $temp_jpg) < (-s $final_file)) {\n        $final_file = $temp_jpg;\n        $file_ext   = 'jpg';\n    }\n\n    my $final_size = (-s $final_file);\n    my $curr_size  = (-s $file);\n\n    $final_size > 0 or return;\n\n    if ($final_size < $curr_size) {\n\n        my $saved = ($curr_size - $final_size) / 1024;\n\n        $total_savings += $saved;\n\n        printf(\":: Saved: %.2fKB (%.2fMB -> %.2fMB) (%.2f%%) ($file_format -> $file_ext)\\n\\n\",\n               $saved,\n               $curr_size / 1024**2,\n               $final_size / 1024**2,\n               ($curr_size - $final_size) / $curr_size * 100);\n\n        my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks) = stat($file);\n\n        if (not $keep_original) {\n            unlink($file) or return;\n        }\n\n        my $new_file = ($file =~ s/\\.(?:png|jpe?g)\\z//ir) . $suffix . '.' . $file_ext;\n\n        while (-e $new_file) {    # lazy solution\n            $new_file .= '.' . $file_ext;\n        }\n\n        copy($final_file, $new_file) or do {\n            warn \"[!] Can't copy <<$final_file>> to <<$new_file>>: $!\\n\";\n            return;\n        };\n\n        # Set the original ownership of the image\n        chown($uid, $gid, $new_file);\n\n        if ($preserve_attr) {\n\n            # Set the original modification time\n            utime($atime, $mtime, $new_file)\n              or warn \"Can't change timestamp: $!\\n\";\n\n            # Set original permissions\n            chmod($mode & 07777, $new_file)\n              or warn \"Can't change permissions: $!\\n\";\n        }\n    }\n    else {\n        printf(\":: The image is already very well compressed. Skipping...\\n\\n\");\n    }\n\n    return 1;\n}\n\nforeach my $type (keys %types) {\n\n    my $ref = $types{$type};\n\n    if ($jpeg_only and $ref->{format} eq 'png') {\n        next;\n    }\n\n    if ($png_only and $ref->{format} eq 'jpg') {\n        next;\n    }\n\n    foreach my $file (@{$ref->{files}}) {\n        if ($ref->{format} eq 'png') {\n            say \":: Processing PNG file: $file\";\n            recompress_image($file, 'png');\n\n        }\n        elsif ($ref->{format} eq 'jpg') {\n            say \":: Processing JPEG file: $file\";\n            recompress_image($file, 'jpg');\n        }\n        else {\n            say \"ERROR: unknown format type for file: $file\";\n        }\n    }\n}\n\nunlink($temp_jpg);\nunlink($temp_png);\n\nprintf(\":: Total savings: %.2fKB\\n\", $total_savings),\n"
  },
  {
    "path": "Image/remove_sensitive_exif_tags.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 09 October 2019\n# https://github.com/trizen\n\n# Remove sensitive EXIF information from images that may be used for online-tracking.\n\n# The script uses the \"exiftool\".\n#   https://www.sno.phy.queensu.ca/~phil/exiftool/\n\n# This is particularly necessary for photos downloaded from Facebook, which include a tracking ID inside them.\n#   https://news.ycombinator.com/item?id=20427007\n#   https://dustri.org/b/on-facebooks-pictures-watermarking.html\n#   https://www.hackerfactor.com/blog/index.php?/archives/726-Facebook-Tracking.html\n#   https://www.reddit.com/r/privacy/comments/ccndcq/facebook_is_embedding_tracking_data_inside_the/\n\nuse 5.020;\nuse warnings;\nuse File::Find qw(find);\n\nuse Getopt::Std qw(getopts);\nuse experimental qw(signatures);\n\nmy %opts;\ngetopts('ea', \\%opts);    # flag \"-e\" removes extra tags\n\nmy $extra      = $opts{e} || 0;          # true to remove additional information, such as the camera name\nmy $all        = $opts{a} || 0;          # true to remove all tags\nmy $batch_size = 100;                    # how many files to process at once\nmy $image_re   = qr/\\.(png|jpe?g)\\z/i;\n\nsub strip_tags ($files) {\n\n    say \":: Stripping tracking tags of \", scalar(@$files), \" photos...\";\n    say \":: The first image is: $files->[0]\";\n\n    system(\n        \"exiftool\",\n\n        \"-overwrite_original_in_place\",    # overwrite image in place\n\n        \"-*Serial*Number*=\",               # remove serial number of camera photo\n        \"-*ImageUniqueID*=\",               # remove the unique image ID\n        \"-*Copyright*=\",                   # remove copyright data\n        \"-usercomment=\",                   # remove any user comment\n        \"-iptc=\",                          # remove any IPTC data\n        \"-xmp=\",                           # remove any XMP data\n        \"-geotag=\",                        # remove geotag data\n        \"-gps:all=\",                       # remove ALL GPS data\n\n        (\n         $extra\n         ? (\n            \"-make=\",                      # remove the brand name of the camera used to make the photo\n            \"-model=\",                     # remove the model name of the camera used to make the photo\n            \"-software=\",                  # remove the software name used to edit/process the photo\n            \"-imagedescription=\",          # remove any image description\n           )\n         : ()\n        ),\n\n        ($all ? (\"-all=\") : ()),\n\n        @$files\n          );\n}\n\nmy @files;\n\n@ARGV or die \"usage: perl script.pl -[ea] [dirs | files]\\n\";\n\nfind(\n    {\n     no_chdir => 1,\n     wanted   => sub {\n         if (/$image_re/ and -f $_) {\n\n             push @files, $_;\n\n             if (@files >= $batch_size) {\n                 strip_tags(\\@files);\n                 @files = ();\n             }\n         }\n     }\n    } => @ARGV\n);\n\nif (@files) {\n    strip_tags(\\@files);\n}\n\nsay \":: Done!\";\n"
  },
  {
    "path": "Image/resize_images.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 30 October 2023\n# Edit: 26 September 2025\n# https://github.com/trizen\n\n# Resize images to a given width or height, keeping aspect ratio.\n\nuse 5.036;\nuse Imager       qw();\nuse File::Find   qw(find);\nuse List::Util   qw(min max);\nuse Getopt::Long qw(GetOptions);\n\nmy $width  = 'auto';\nmy $height = 'auto';\nmy $min    = 'auto';\nmy $max    = 'auto';\nmy $qtype  = 'mixing';\nmy $outdir = undef;\n\nmy $img_formats   = '';\nmy $preserve_attr = 0;\n\nmy @img_formats = qw(\n  jpeg\n  jpg\n  png\n);\n\nsub usage ($code) {\n    local $\" = \",\";\n    print <<\"EOT\";\nusage: $0 [options] [dirs | files]\n\noptions:\n    -w  --width=i     : resize images to this width\n    -h  --height=i    : resize images to this height\n\n        --min=i       : resize images to have the smallest side equal to this\n        --max=i       : resize images to have the largest side equal to this\n\n    -q  --quality=s   : quality of scaling: 'normal', 'preview' or 'mixing' (default: $qtype)\n    -f  --formats=s,s : specify more image formats (default: @img_formats)\n    -p  --preserve!   : preserve file original timestamps and metadata info\n    -o  --outdir=s    : create resized images into this directory\n\nexamples:\n\n    $0 --min=1080 *.jpg     # smallest side = 1080 pixels\n    $0 --height=1080 *.jpg  # height = 1080 pixels\n\nEOT\n\n    exit($code);\n}\n\nGetOptions(\n           'w|width=i'   => \\$width,\n           'h|height=i'  => \\$height,\n           'minimum=i'   => \\$min,\n           'maximum=i'   => \\$max,\n           'q|quality=s' => \\$qtype,\n           'f|formats=s' => \\$img_formats,\n           'p|preserve!' => \\$preserve_attr,\n           'o|outdir=s'  => \\$outdir,\n           'help'        => sub { usage(0) },\n          )\n  or die(\"Error in command line arguments\");\n\npush @img_formats, map { quotemeta } split(/\\s*,\\s*/, $img_formats);\n\nmy $img_formats_re = do {\n    local $\" = '|';\n    qr/\\.(@img_formats)\\z/i;\n};\n\nif (defined($outdir)) {\n\n    if (not -d $outdir) {\n        require File::Path;\n        File::Path::make_path($outdir)\n          or die \"Can't create output directory <<$outdir>>: $!\";\n    }\n\n    require File::Basename;\n    require File::Spec::Functions;\n}\n\nsub resize_image ($image) {\n\n    my $img = Imager->new(file => $image) or do {\n        warn \"Failed to load <<$image>>: \", Imager->errstr();\n        return;\n    };\n\n    my ($curr_width, $curr_height) = ($img->getwidth, $img->getheight);\n\n    if ($min ne 'auto' and $min > 0) {\n\n        if (min($curr_width, $curr_height) <= $min) {\n            say \"Image too small to resize\";\n            return;\n        }\n\n        if ($curr_width < $curr_height) {\n            $img = $img->scale(xpixels => $min, qtype => $qtype);\n        }\n        else {\n            $img = $img->scale(ypixels => $min, qtype => $qtype);\n        }\n    }\n    elsif ($max ne 'auto' and $max > 0) {\n\n        if (max($curr_width, $curr_height) <= $max) {\n            say \"Image too small to resize\";\n            return;\n        }\n\n        if ($curr_height > $curr_width) {\n            $img = $img->scale(ypixels => $max, qtype => $qtype);\n        }\n        else {\n            $img = $img->scale(xpixels => $max, qtype => $qtype);\n        }\n    }\n    elsif ($height ne 'auto' and $height > 0) {\n        if ($curr_height <= $height) {\n            say \"Image too small to resize\";\n            return;\n        }\n        $img = $img->scale(ypixels => $height, qtype => $qtype);\n    }\n    elsif ($width ne 'auto' and $width > 0) {\n        if ($curr_width <= $width) {\n            say \"Image too small to resize\";\n            return;\n        }\n        $img = $img->scale(xpixels => $width, qtype => $qtype);\n    }\n    else {\n        die \"No --width or --height specified...\";\n    }\n\n    my ($exif_info, $exifTool);\n\n    if ($preserve_attr) {\n        require Image::ExifTool;\n        $exifTool  = Image::ExifTool->new;\n        $exif_info = $exifTool->SetNewValuesFromFile($image);\n    }\n\n    my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks) = stat($image);\n\n    # Create resized image into $outdir directory\n    if (defined($outdir)) {\n        $image = File::Spec::Functions::catfile($outdir, File::Basename::basename($image));\n    }\n\n    $img->write(file => $image) or do {\n        warn \"Failed to rewrite image: \", $img->errstr;\n        return;\n    };\n\n    if ($preserve_attr) {\n\n        $exifTool = Image::ExifTool->new;\n\n        foreach my $key (keys %$exif_info) {\n            my $value = $exif_info->{$key};\n            $exifTool->SetNewValue($key, $value);\n        }\n\n        $exifTool->WriteInfo($image);\n\n        # Set the original modification time\n        utime($atime, $mtime, $image)\n          or warn \"Can't change timestamp: $!\\n\";\n\n        # Set original permissions\n        chmod($mode & 07777, $image)\n          or warn \"Can't change permissions: $!\\n\";\n    }\n\n    # Set the original ownership of the image\n    chown($uid, $gid, $image);\n\n    return 1;\n}\n\n@ARGV || usage(1);\n\nfind {\n    no_chdir => 1,\n    wanted   => sub {\n        (/$img_formats_re/o && -f) || return;\n        say \"Resizing: $_\";\n        resize_image($_);\n    }\n} => @ARGV;\n"
  },
  {
    "path": "Image/rgb_dump.pl",
    "content": "#!/usr/bin/perl\n\n# Dump the first n pixels from a given image.\n\nuse 5.020;\nuse warnings;\n\nuse Imager;\nuse experimental qw(signatures);\n\n@ARGV || do {\n    say STDERR \"usage: $0 [input.png] [n]\";\n    exit(2);\n};\n\nmy $in_file = $ARGV[0];\nmy $n       = $ARGV[1] // 10;\n\nmy $img = 'Imager'->new(file => $in_file)\n  or die \"Can't read image: $in_file\";\n\nmy $width  = $img->getwidth;\nmy $height = $img->getheight;\n\nOUTER: foreach my $y (0 .. $height - 1) {\n    foreach my $x (0 .. $width - 1) {\n        --$n >= 0 or last OUTER;\n        my $color = $img->getpixel(x => $x, y => $y);\n        my ($r, $g, $b) = $color->rgba;\n        printf(\"%08b,%08b,%08b | %2x,%2x,%2x | %3d,%3d,%3d\\n\", ($r, $g, $b) x 3);\n    }\n}\n"
  },
  {
    "path": "Image/sharp_2x_zoom.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 31 October 2015\n# Website: https://github.com/trizen\n\n# Zoom a picture two times, without loosing too much details.\n\n# Requires: wkhtmltoimage\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse GD qw();\nuse File::Temp qw(tempfile);\nuse HTML::Entities qw(encode_entities);\n\nGD::Image->trueColor(1);\n\nsub help {\n    my ($code) = @_;\n    print <<\"HELP\";\nusage: $0 [input image] [output image]\nHELP\n    exit($code);\n}\n\nsub enhance_img {\n    my ($image, $out) = @_;\n\n    my $img = GD::Image->new($image) // return;\n    my ($width, $height) = $img->getBounds;\n\n    my $scale_width  = 2 * $width;\n    my $scale_height = $height;\n\n    my $resized = GD::Image->new($scale_width, $scale_height);\n    $resized->copyResampled($img, 0, 0, 0, 0, $scale_width, $scale_height, $width, $height);\n\n    ($width, $height) = ($scale_width, $scale_height);\n    $img = $resized;\n\n    my @pixels;\n\n    foreach my $y (0 .. $height - 1) {\n        foreach my $x (0 .. $width - 1) {\n            my $index = $img->getPixel($x, $y);\n            push @pixels, [$img->rgb($index)];\n        }\n    }\n\n    my $header = <<\"EOT\";\n<html xmlns=\"https://www.w3.org/1999/xhtml\">\n<head>\n<title>${\\encode_entities($image)}</title>\n<meta http-equiv=\"content-type\" content=\"text/html; charset=utf-8\" />\n<style type=\"text/css\">\n/*<![CDATA[*/\n<!--\n\npre {\n      font-size: 1;\n      font-family: monospace;\n    }\nEOT\n\n    my $footer = <<'EOT';\n</pre></body></html>\nEOT\n\n    my %colors;\n    my $style = '';\n\n    my @html;\n    my $name = 'A';\n\n    while (@pixels) {\n        push @html, [\n            map {\n                my $color = sprintf(\"%02x%02x%02x\", @{$_});\n\n                if (not exists $colors{$color}) {\n                    $colors{$color} = $name;\n                    $style .= \".$name\\{background-color:#$color;}\\n\";\n                    $name++;\n                }\n\n                $colors{$color};\n              } splice(@pixels, 0, $width)\n        ];\n    }\n\n    my $html = '';\n    foreach my $row (@html) {\n\n        while (@{$row}) {\n            my $class = shift @{$row};\n\n            my $count = 1;\n            while (@{$row} and $row->[0] eq $class) {\n                ++$count;\n                shift @{$row};\n            }\n\n            $html .= qq{<span class=\"$class\">} . (' ' x $count) . \"</span>\";\n        }\n\n        $html .= '<br/>';\n    }\n\n    $style .= <<'EOT';\n-->\n/*]]>*/\n</style>\n</head>\n<body>\n<pre>\nEOT\n\n    $html = join('', $header, $style, $html, $footer);\n\n    my ($fh, $tmpfile) = tempfile(UNLINK => 1, SUFFIX => '.html');\n    print $fh $html;\n    close $fh;\n\n    system(\n           'wkhtmltoimage', '--quality',     '100',      '--crop-h', $height * 2,\n           '--crop-w',      $width,          '--crop-x', '8',        '--crop-y',\n           '8',             '--transparent', '--quiet',  $tmpfile,   $out\n          );\n}\n\nmy $img = $ARGV[0] // help(1);\nmy $out = $ARGV[1] // help(1);\nenhance_img($img, $out);\n"
  },
  {
    "path": "Image/slideshow.pl",
    "content": "#!/usr/bin/perl\n\n# Create a video slideshow from a collection of images, given a glob pattern.\n\n# Usage:\n#   perl slideshow.pl 'glob_pattern*.jpg' 'output.mp4'\n\nuse 5.036;\nuse Getopt::Long qw(GetOptions);\n\nmy $width  = 1920;\nmy $height = 1080;\nmy $delay  = 2;\n\nGetOptions(\n           \"width=i\"  => \\$width,\n           \"height=i\" => \\$height,\n           \"delay=i\"  => \\$delay\n          )\n  or die(\"Error in command line arguments\\n\");\n\n@ARGV == 2 or die <<\"USAGE\";\nusage: $0 [options] [glob pattern] [output.mp4]\n\noptions:\n\n    --width=i   : width of the video (default: $width)\n    --height=i  : height of the video (default: $height)\n    --delay=i   : delay in seconds between pictures (default: $delay)\nUSAGE\n\nsystem('ffmpeg', qw(-framerate),\n       join('/', 1, $delay),\n       qw(-pattern_type glob -i),\n       $ARGV[0], '-vf',\n       \"scale=${width}:${height}:force_original_aspect_ratio=decrease,pad=${width}:${height}:(ow-iw)/2:(oh-ih)/2\",\n       qw(-c:v libx264 -s),\n       join('x', $width, $height),\n       qw(-crf 18 -tune stillimage -r 24),\n       $ARGV[1]);\n"
  },
  {
    "path": "Image/vertical_scrambler.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 05 April 2024\n# https://github.com/trizen\n\n# Scramble the pixels in each column inside an image, using a deterministic method.\n\nuse 5.036;\nuse GD;\nuse Getopt::Std qw(getopts);\n\nGD::Image->trueColor(1);\n\nsub scramble ($str) {\n    my $i = length($str);\n    $str =~ s/(.{$i})(.)/$2$1/gs while (--$i > 0);\n    return $str;\n}\n\nsub unscramble ($str) {\n    my $i = 0;\n    my $l = length($str);\n    $str =~ s/(.)(.{$i})/$2$1/gs while (++$i < $l);\n    return $str;\n}\n\nsub scramble_image ($file, $function) {\n\n    my $image = GD::Image->new($file) || die \"Can't open file <<$file>>: $!\";\n    my ($width, $height) = $image->getBounds();\n\n    my $new_image = GD::Image->new($width, $height);\n\n    foreach my $x (0 .. $width - 1) {\n\n        my (@R, @G, @B);\n        foreach my $y (0 .. $height - 1) {\n            my ($R, $G, $B) = $image->rgb($image->getPixel($x, $y));\n            push @R, $R;\n            push @G, $G;\n            push @B, $B;\n        }\n\n        @R = unpack('C*', $function->(pack('C*', @R)));\n        @G = unpack('C*', $function->(pack('C*', @G)));\n        @B = unpack('C*', $function->(pack('C*', @B)));\n\n        foreach my $y (0 .. $height - 1) {\n            $new_image->setPixel($x, $y, $new_image->colorAllocate($R[$y], $G[$y], $B[$y]));\n        }\n    }\n\n    return $new_image;\n}\n\nsub usage ($exit_code = 0) {\n\n    print <<\"EOT\";\nusage: $0 [options] [input.png] [output.png]\n\noptions:\n\n    -d : decode the image\n    -h : print this message and exit\n\nEOT\n\n    exit($exit_code);\n}\n\ngetopts('dh', \\my %opts);\n\nmy $input_file  = $ARGV[0] // usage(2);\nmy $output_file = $ARGV[1] // \"output.png\";\n\nif (not -f $input_file) {\n    die \"Input file <<$input_file>> does not exist!\\n\";\n}\n\nmy $img = $opts{d} ? scramble_image($input_file, \\&unscramble) : scramble_image($input_file, \\&scramble);\nopen(my $out_fh, '>:raw', $output_file) or die \"can't create output file <<$output_file>>: $!\";\nprint $out_fh $img->png(9);\nclose $out_fh;\n"
  },
  {
    "path": "Image/visualize_binary.pl",
    "content": "#!/usr/bin/perl\n\n# Visualize a given input stream of bytes, as a PGM (P5) image.\n\nuse 5.014;\nuse strict;\nuse warnings;\n\nuse Getopt::Long qw(GetOptions);\n\nmy $width  = 0;\nmy $height = 0;\nmy $colors = 255;\n\nsub print_usage {\n    print <<\"EOT\";\nusage: $0 [options] [<input.bin] [>output.pgm]\n\noptions:\n\n    --width=i   : width of the image (default: $width)\n    --height=i  : height of the image (default: $height)\n    --colors=i  : number of colors (default: $colors)\n    --help      : display this message and exit\n\nEOT\n    exit;\n}\n\nGetOptions(\n           \"w|width=i\"  => \\$width,\n           \"h|height=i\" => \\$height,\n           \"c|colors=i\" => \\$colors,\n           \"help\"       => \\&print_usage,\n          )\n  or die \"Error in arguments\";\n\nbinmode(STDIN,  ':raw');\nbinmode(STDOUT, ':raw');\n\nmy $data = do {\n    local $/;\n    <>;\n};\n\nif (!$width or !$height) {\n    $width  ||= ($height ? int(length($data) / $height) : int(sqrt(length($data))));\n    $height ||= int(length($data) / $width);\n}\n\nprint \"P5 $width $height $colors\\n\";\nprint $data;\n"
  },
  {
    "path": "Image/webp2png.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 10 April 2021\n# https://github.com/trizen\n\n# Convert WEBP images to PNG, using the `dwebp` tool from \"libwebp\".\n\n# The original WEBP files are deleted.\n\nuse 5.036;\nuse File::Find   qw(find);\nuse Getopt::Long qw(GetOptions);\n\nmy $dwebp_cmd    = \"dwebp\";    # `dwebp` command\nmy $use_exiftool = 0;          # true to use `exiftool` instead of `File::MimeInfo::Magic`\n\n`$dwebp_cmd -h`\n  or die \"Error: `$dwebp_cmd` tool from 'libwebp' is not installed!\\n\";\n\nsub webp2png ($file) {\n\n    my $orig_file = $file;\n    my $png_file  = $file;\n\n    if ($png_file =~ s/\\.webp\\z/.png/i) {\n        ## ok\n    }\n    else {\n        $png_file .= '.png';\n    }\n\n    if (-e $png_file) {\n        warn \"[!] File <<$png_file>> already exists...\\n\";\n        next;\n    }\n\n    system($dwebp_cmd, $orig_file, '-o', $png_file);\n\n    if ($? == 0 and (-e $png_file) and ($png_file ne $orig_file)) {\n        unlink($orig_file);\n    }\n    else {\n        return;\n    }\n\n    return 1;\n}\n\nsub determine_mime_type ($file) {\n\n    if ($file =~ /\\.webp\\z/i) {\n        return \"image/webp\";\n    }\n\n    if ($use_exiftool) {\n        my $res = `exiftool \\Q$file\\E`;\n        $? == 0       or return;\n        defined($res) or return;\n        if ($res =~ m{^MIME\\s+Type\\s*:\\s*(\\S+)}mi) {\n            return $1;\n        }\n        return;\n    }\n\n    require File::MimeInfo::Magic;\n    File::MimeInfo::Magic::magic($file);\n}\n\nmy %types = (\n             'image/webp' => {\n                              call => \\&webp2png,\n                             }\n            );\n\nGetOptions('exiftool!' => \\$use_exiftool,)\n  or die \"Error in command-line arguments!\";\n\n@ARGV or die <<\"USAGE\";\nusage: perl $0 [options] [dirs | files]\n\noptions:\n\n    --exiftool : use `exiftool` to determine the MIME type (default: $use_exiftool)\n\nUSAGE\n\nfind(\n    {\n     no_chdir => 1,\n     wanted   => sub {\n\n         (-f $_) || return;\n         my $type = determine_mime_type($_) // return;\n\n         if (exists $types{$type}) {\n             $types{$type}{call}->($_);\n         }\n     }\n    } => @ARGV\n);\n\nsay \":: Done!\";\n"
  },
  {
    "path": "Image/zuper_image_decoder.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 26 November 2022\n# https://github.com/trizen\n\n# A decoder for the Zuper (ZPR) image format, generating PNG images.\n\nuse 5.020;\nuse warnings;\n\nuse Imager;\nuse experimental           qw(signatures);\nuse IO::Uncompress::UnZstd qw(unzstd $UnZstdError);\n\nsub zpr_decoder ($bytes) {\n\n    my sub invalid() {\n        die \"Not a ZPR image\";\n    }\n\n    my $index = 0;\n\n    pack('C4', map { $bytes->[$index++] } 1 .. 4) eq 'zprf' or invalid();\n\n    my $width  = unpack('N', pack('C4', map { $bytes->[$index++] } 1 .. 4));\n    my $height = unpack('N', pack('C4', map { $bytes->[$index++] } 1 .. 4));\n\n    my $channels   = $bytes->[$index++];\n    my $colorspace = $bytes->[$index++];\n\n    ($width > 0 and $height > 0) or invalid();\n    ($channels > 0 and $channels <= 4) or invalid();\n    ($colorspace == 0 or $colorspace == 1) or invalid();\n\n    pop(@$bytes) == 0x01 or invalid();\n\n    for (1 .. 7) {\n        pop(@$bytes) == 0x00 or invalid();\n    }\n\n    say \"[$width, $height, $channels, $colorspace]\";\n\n    my $len = unpack('N', pack('C4', map { $bytes->[$index++] } 1 .. 4));\n\n    scalar(@$bytes) - $index == $len or invalid();\n\n    splice(@$bytes, 0, $index);\n    my $z = pack('C' . $len, @$bytes);\n\n    unzstd(\\$z, \\my $all_channels)\n      or die \"unzstd failed: $UnZstdError\\n\";\n\n    my $img = 'Imager'->new(\n                            xsize    => $width,\n                            ysize    => $height,\n                            channels => $channels,\n                           );\n\n    my @channels = unpack(sprintf(\"(a%d)%d\", $width * $height, $channels), $all_channels);\n    my $diff = 4 - $channels;\n\n    foreach my $y (0 .. $height - 1) {\n        my $row = '';\n        foreach my $x (1 .. $width) {\n            $row .= substr($_, 0, 1, '') for @channels;\n            $row .= chr(0) x $diff if $diff;\n        }\n        $img->setscanline(y => $y, pixels => $row);\n    }\n\n    return $img;\n}\n\n@ARGV || do {\n    say STDERR \"usage: $0 [input.zpr] [output.png]\";\n    exit(2);\n};\n\nmy $in_file  = $ARGV[0];\nmy $out_file = $ARGV[1] // \"$in_file.png\";\n\nmy @bytes = do {\n    open(my $fh, '<:raw', $in_file)\n      or die \"Can't open file <<$in_file>> for reading: $!\";\n    local $/;\n    unpack(\"C*\", scalar <$fh>);\n};\n\nmy $img = zpr_decoder(\\@bytes);\n$img->write(file => $out_file, type => 'png');\n"
  },
  {
    "path": "Image/zuper_image_encoder.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 26 November 2022\n# https://github.com/trizen\n\n# A very simple lossless image encoder, using Zstandard compression.\n\n# Pretty good at compressing computer-generated images.\n\nuse 5.020;\nuse warnings;\n\nuse Imager;\nuse experimental       qw(signatures);\nuse IO::Compress::Zstd qw(zstd $ZstdError);\n\nsub zuper_encoder ($img, $out_fh) {\n\n    my $width      = $img->getwidth;\n    my $height     = $img->getheight;\n    my $channels   = $img->getchannels;\n    my $colorspace = 0;\n\n    say \"[$width, $height, $channels, $colorspace]\";\n\n    my @header = unpack('C*', 'zprf');\n\n    push @header, unpack('C4', pack('N', $width));\n    push @header, unpack('C4', pack('N', $height));\n\n    push @header, $channels;\n    push @header, $colorspace;\n\n    my $index    = 0;\n    my @channels = map { \"\" } (1 .. $channels);\n\n    foreach my $y (0 .. $height - 1) {\n\n        my @line     = split(//, scalar $img->getscanline(y => $y));\n        my $line_len = scalar(@line);\n\n        for (my $i = 0 ; $i < $line_len ; $i += 4) {\n            my @px = splice(@line, 0, 4);\n            foreach my $j (0 .. $channels - 1) {\n                $channels[$j] .= $px[$j];\n            }\n            ++$index;\n        }\n    }\n\n    my @footer;\n    push(@footer, (0x00) x 7);\n    push(@footer, 0x01);\n\n    my $all_channels = '';\n\n    foreach my $channel (@channels) {\n        $all_channels .= $channel;\n    }\n\n    zstd(\\$all_channels, \\my $z)\n      or die \"zstd failed: $ZstdError\\n\";\n\n    my $before = length($all_channels);\n    my $after  = length($z);\n\n    say \"Compression: $before -> $after (saved \", sprintf(\"%.2f%%\", 100 - $after / $before * 100), \")\";\n\n    # Header\n    print $out_fh pack('C*', @header);\n\n    # Compressed data\n    print $out_fh pack('N', $after);\n    print $out_fh $z;\n\n    # Footer\n    print $out_fh pack('C*', @footer);\n}\n\n@ARGV || do {\n    say STDERR \"usage: $0 [input.png] [output.zpr]\";\n    exit(2);\n};\n\nmy $in_file  = $ARGV[0];\nmy $out_file = $ARGV[1] // \"$in_file.zpr\";\n\nmy $img = 'Imager'->new(file => $in_file)\n    or die \"Can't read image: $in_file\";\n\nopen(my $out_fh, '>:raw', $out_file)\n  or die \"Can't open file <<$out_file>> for writing: $!\";\n\nzuper_encoder($img, $out_fh);\n"
  },
  {
    "path": "JAPH/alien_japh.pl",
    "content": "                   read*DATA,$_,13**+3;y #{}\n                 {}{};s>[\\s*]+>>g;$i=length;s/\n              (.{$i})(.)/$2$1/gx while$i--;eval;;\n           ;for(q\\just \\.q)another),q)perl hacker)){\n         for(split$!){$_=$$h{$_}?do{$_=$$h{$_};;;;;;;y\n       <A-Za-z0-9+/>/ -_/&&unpack'u',chr(length()*.75+32\n      ).$_}:$\"x$];$w=(sort{$b<=>$a}map+length,split$\\=$/)\n     [$]-$]];s/^(.*?)\\s*$/sprintf'%-*s',$w,$1/egm;push@f,[\n    [split$\\],$w]}for$x($?..-//+$]){push@{$x[$x]},@{$f[$_][\n   $?]}?pop@{$f[$_][$?]}:$\"x$f[$_][//]for$?..$#f}$s.=\"@{+pop\n  @x}$/\"while@x;$k=$g=chr(ord$^);for(split$\\,$s){$s=$g;$$s=$_\n  ;++$g}$==135;print$w=\"\\e[H\",\"\\e[J\";{print$w;print$\"x$=,$$_?\n chop$$_:''for$k..$g;select$,,$,,$,,.01;--$=&&redo}}__END__!!!\n C**wX*yX****o*f*****ig*pv*AoB**LhCffX*g*I**I*lyI****8*g*FC8L8\n 8**v*I*LC*g9*8I*o81ga***ICXp*I*Ig8***CIv*wF*B*8*I*8*wX**gCvIA\n g*LA,L>8*Cg*CCyy*w**cIi**F>*L=8**L*X**='CgCLfg*vC8wXgX*Kef*9*\nB8C**I*g*gvIALKX*L**C*vy*>I*gX***I*Xg8**w1*}CA*=y8*y******lAyw*\n=8C*gy*f****f**y*8**loK****K88A**8f=,*II****'g*f*F*F*wf*v**gvCA\nC8*y*y*LIgK******Xf''***'*I***A*X=yiov***g>C*,*8*g****IAgvA*I*X\nFj**gCy*8Xv**89v'*XI*ILy**=A**C1A*8y*v*o**v9KvXyw**f**f**X8**C*\n*Fy******C*C9**L*vf**C*vF*8gg$*y**v*8v**AL**II*ILKsK*Xyv**gCI**\n8**y        fI**K*F*8**L*,*I9*C**8*BiFw*fg,A8h8*gF'        B***\nvg*L           *8*C*8*F*fX*CC8*g*B***,Iv88A*****           gC8X\n*1*C              C***IF*u******CX8**L>Xi=***              *C**\nC*v8*               **ICI8I*>*KC***8IF*B*8*               *oIF*\n**K**                Av*ALvg**C*I*g**'*wBA                **FLg\n*'1''*                 f=*yLLI*****'ff'*                 *fo*9g\n *IA>y                  F***v*8FIoy'*C*                  *Lf**\n I*8f8v                  *k'y8F*=vw*>g                  **Kf**\n  vy8*X>                  *K*L*XgKw*'                  o*g'vF\n   *1By'                   gBv*LI***                   XX8**\n   KB***'                  Xv**A'**8                  v***of\n    ilgCgC*                 **'***f                 y*BA*8i\n     **LI*y*                *8IoIv*                *oC,y*g\n      ,**gI**=               *yC8i               'I8g*L>8\n       '9{8gB*>A             F*18I             **8A=*v**\n        *yA'*1pf**           *wv**           ****,I8l*v\n         *IAB*AC*f**f       I**yA**       yF*C1*Avp***\n          **gCv'*****KIyK******8C'g9I**yFK*IL8*A=vo*y\n           C*ABX*F*fv8***AC,*9***wy***IKI****,Kn=i**\n            **Xf8w*L1*w*9***8*,ygf*X**88oKCIC***I**\n             I*8*'*F8IL***CL**y*>*>I*****fCC*8LC*y\n               **XC***A*I*g*C*FA*w****Bv**CfyA*I\n                g*I*y*****A*BI9'g**gy*Iw*L8*lgX\n                 *IXXX*A**X**8g*I88*I***B*i***\n                   *y**X*FXAyg****Avgo*F*F*F\n                     *XAg*gC*i****,*LI**>*\n                       IK*I*Xg****tv****\n                         XCA**8pr*CIg*\n                           A*K=***y*\n"
  },
  {
    "path": "JAPH/alpha_ascii_japh.pl",
    "content": "print q q q x length time and print chr length qq q exec getc getgrent glob goto\ngetgrnam getsockname getsockopt getgrgid gmtime grep getprotoent q and print chr\nlength time and print q q q and print q q q and print chr length q q caller chop\nchdir chmod chomp chown chr chroot close closedir continue connect cos crypt die\ndbmclose dbmopen defined dump q and print q q  q and print chr length q q import\nbinmode bless each no formline package q and do s ss q q readpipe qx length time\nsex xor s t readpipe tr t xor print chr length xor print q q  q xor s y y x yggg\nxor s sissg xor s trt qq t xor print chr length xor print chr length qq q splice\nsetpwent setsockopt shift shmctl study socketpair sort split sprintf srand utime\nwrite q xor eval print chr length xor print q q q xor print chr length xor print\nchr length q q scalar seekdir sethostent select semctl semget semop send setpgrp\nsetgrent opendir sub listen q xor print chr length xor print chr length time xor\nprint chr length xor s spssg xor s sassg xor s s rss xor printf chr length xor s\ns s q q x q x length time sex xor s s ss xor do print chr length xor print q q q\nxor s s ssg xor s sessg xor s exee xor print chr length xor s sxxssx xor do eval\nprint chr length xor print chr length xor s sxsxxxsg xor s sxxxxxssx xor do eval\nprint chr length xor print q q q xor s sxsq q x q x length time se xor s sx sxxx\nsx xor print chr length xor print qq q   q xor print chr length xor print qq q q\nxor print chr length xor s yy do eval print chr length time foreach qw qr x q ye\n"
  },
  {
    "path": "JAPH/alpha_japh.pl",
    "content": "print chr length qw a b a x ord qq bJb and\nprint chr length qw b c b x ord qq cuc and\nprint chr length qw c d c x ord qq dsd and\nprint chr length qw d e d x ord qq ete and\nprint chr length qw e f e x ord qq f f and\nprint chr length qw f g f x ord qq gag and\nprint chr length qw g h g x ord qq hnh and\nprint chr length qw h i h x ord qq ioi and\nprint chr length qw i j i x ord qq jtj and\nprint chr length qw j k j x ord qq khk and\nprint chr length qw k l k x ord qq lel and\nprint chr length qw l m l x ord qq mrm and\nprint chr length qw m n m x ord qq n n and\nprint chr length qw n o n x ord qq oPo and\nprint chr length qw o p o x ord qq pep and\nprint chr length qw p q p x ord qq qrq and\nprint chr length qw q r q x ord qq rlr and\nprint chr length qw r s r x ord qq s s and\nprint chr length qw s t s x ord qq tht and\nprint chr length qw t u t x ord qq uau and\nprint chr length qw u v u x ord qq vcv and\nprint chr length qw v w v x ord qq wkw and\nprint chr length qw w x w x ord qq xex and\nprint chr length qw x y x x ord qq yry and\nprint chr length time and do not eval exit\n"
  },
  {
    "path": "JAPH/alpha_japh_2.pl",
    "content": "print chr length o x ord qw o J o and\nprint chr length o x ord qw x u x and\nprint chr length o x ord qw o s o and\nprint chr length o x ord qw x t x and\nprint chr length o x ord qq o   o and\nprint chr length o x ord qw x a x and\nprint chr length o x ord qw o n o and\nprint chr length o x ord qw x o x and\nprint chr length o x ord qw o t o and\nprint chr length o x ord qw x h x and\nprint chr length o x ord qw o e o and\nprint chr length o x ord qw x r x and\nprint chr length o x ord qq o   o and\nprint chr length o x ord qw x P x and\nprint chr length o x ord qw o e o and\nprint chr length o x ord qw x r x and\nprint chr length o x ord qw o l o and\nprint chr length o x ord qq x   x and\nprint chr length o x ord qw o h o and\nprint chr length o x ord qw x a x and\nprint chr length o x ord qw o c o and\nprint chr length o x ord qw x k x and\nprint chr length o x ord qw o e o and\nprint chr length o x ord qw x r x and\nprint chr length time and do not exit\n"
  },
  {
    "path": "JAPH/alpha_japh_3.pl",
    "content": "qw qxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxqand\ns yys xxprint scalar reverse q qrekcah lreP rehtona tsuJqxe and print qq x\nxyexxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n"
  },
  {
    "path": "JAPH/arrow_japh.pl",
    "content": "!_&print q qJq or\n!__&print q quq or\n!___&print q qsq or\n!____&print q qtq or\n!_____&print q q q or\n!______&print q qaq or\n!_______&print q qnq or\n!________&print q qoq or\n!_________&print q qtq or\n!__________&print q qhq or\n!___________&print q qeq or\n!____________&print q qrq or\n!____________&print q q q or\n!____________&print q qPq or\n!___________&print q qeq or\n!__________&print q qrq or\n!_________&print q qlq or\n!________&print q q q or\n!_______&print q qhq or\n!______&print q qaq or\n!_____&print q qcq or\n!____&print q qkq or\n!___&print q qeq or\n!__&print q qrq or\n!_&print q q,q,$/\n"
  },
  {
    "path": "JAPH/barewords_japh.pl",
    "content": "Just another Perl hacker\n\nlocal+$,=$\";package another;sub Just{print(substr((caller(0))[3],3**2),@_)}\npackage hacker;sub Perl{Just another((split/:./,(caller(0))[3])[1,0]),exit}\n"
  },
  {
    "path": "JAPH/cubic_japh.pl",
    "content": "       +($\\,$})=($/,q$@$);@@=split$!=>($@\n      =$}|'/'=>$:=$@,++$@,$@++,$~=(++$@=>\n     ++$@),$.=$\",$_=$/|$}.(+(++$@=>++$@).\n    $~).++$~.$..($;=$}|'!').($^='.'|$}).+\n   ('/'|$}).$~.($@=$}|'(').($\"='%'|$}).(+\n  +++$:=>++$:,+++$:).$..($:^'\"').$\".$:.(q\n },}|$}).$..$@.$;.($}.$}|'#+').$\".$:.q|,|\n );sub f{print@_}sub i(_){my($l,$j)=0;my(\n $x,$y,$z,$c,$h,$v,$d,$s,$p,$o)=(+@{+pop}\n ,qw w+ -w,qw\\| /\\,sub{$j=$_[0];$l+$j>+@@\n &&($l=$?);@@[do{$l=$j+$l;$l-$j..$l-1}]},\n $?);f$.x($z+1),$c,$h x$x,$c;f$.x($z-$_+1\n ),$d,$s->($x),$d,$s->($_-1-$p),$_>$y?!$p\n &&++$p?do{$o=$z-$y;$c}:$p++?$d:$c:$v for\n 1..$z;f$c,$h x$x,$c,$p?($s->($z-$o),$d):\n ($s->($z),$z<$y?$v:$c);f$v,$s->($x),$v,\n ,$z-1>=$y?$_>=$z?($s->($x),$c):($s->($\n z-$_-$o),$d):$y-$_>$z?($s->($z),$v):(\n $s->($y-$_),$y-$_==$z?$c:$d)for+1..$\n y;f$c,$h x$x,$c}+i,,for[24,24,24],[\n 1,24,0],[24,1,0],[1,0,24],[24,3,1]\n"
  },
  {
    "path": "JAPH/invisible_japh.pl",
    "content": "open _=>\">$0\";print _+'print chr length for split\"\\5\"=>qq;';print _+qq\n\"\\0\"x+ord($_)=>\"\\5\"for(split//=>join''=>'Vioh<}rshtyn<Lynp<t}'^$;x(ord\n($/)*(++$-*$-++)),'iaox,'^$/x($-**$-),$/);print _ ';';close _;do\"./$0\"\n"
  },
  {
    "path": "JAPH/japh_from_ambiguity.pl",
    "content": "print $$ /0;        # a legit division by zero\n\n^....super....^\n^....black....^\n^....magic....^\n\n|(?{m}(?{\"\\[\\[\\)\n\\.\\\\\\|\\`\\]\\[\\[\\{\n\\[\\.\\@\\/\\(\\^\\.\\[\n\\{\\;\\\\\\,\\[\\@\\:\\?\n\\+\\^\\)\\(\"=~s\\}[\\\n\\s]\\}\\}rg^\"\\+\\)\\\n\\@\\@\\(\\^\\*\\(\\(\\/\n\\[\\:\\@\\/\\[\\@\\;\\\\\n\\{\\+\\^\\.\\@\\{\\(\\[\n\\\\\\@\\;\\[\\\"\\\"\"=~s\n\\}\\s\\}\\}gr\\})},s\n\\/\\/$^R\\/esex})|\n\n^....hugs....^\n^.....&&.....^\n^...kisses...^\n\n //\n//xo//xo//xo//xo//xo//xo//xo//\n                           //\n"
  },
  {
    "path": "JAPH/japh_from_auto-quoted_keywords.pl",
    "content": "print chr ord for join=>utime=>seek=>tell=>$\"=>alarm=>next=>\nour=>tied=>hex=>each=>recv=>$\"=>pipe=>exit=>redo=>lock=>$\"=>\nhex=>accept=>connect=>keys=>eof=>rewinddir=>chr length time;\n"
  },
  {
    "path": "JAPH/japh_from_escapes.pl",
    "content": "'J \t \u0007\no\t \u001b\r P\u001b\r \t\u0007\u000b\u001b\r'=~($_=qr/^J\\u\\s\\t \\a\\no\\t\\h\\e\\r P\\e\\r\\l \\h\\a\\ck\\e\\r$/)&&\nprint s/(?(?{$-[0]==$=\\/2})(?{'l'})|(?{$!}))|^\\W+(.)(?{$1\n.($1^'?')})|[\\\\^](?=\\w)(?{$@})|\\W+\\z(?{\",$\\/\"})/$^R/girls\n"
  },
  {
    "path": "JAPH/japh_from_eval_subst.pl",
    "content": "s/(?{(('[[).\\|`][[{[.@\\/(^.[{;\\,[@:?+^)('^'+)@@(^*((\\/[:@\\/[@;\\{+^.@{([\\@;[\"').'\"')})/$^R/ee\n"
  },
  {
    "path": "JAPH/japh_from_keywords.pl",
    "content": "join eval tell rand reverse ord chr eval split xor\nuc prototype eval lcfirst join chmod kill eval ref\nsplit sprintf reverse times xor not eval and srand\ntell sqrt formline eval ord lcfirst ucfirst length\n glob gmtime exp defined caller or binmode log ord\nabs lc sqrt study alarm split time or formline cos\nne rewinddir kill chdir reset prototype split sqrt\nord int localtime abs oct pack pop eq scalar print\ntelldir open unpack return and unlink write chroot\nhex bless utime split chown split close rmdir join\nexp fileno getc sleep redo glob mkdir stat ne pack\nreverse getpwnam next lstat gethostent and getpgrp\n eq log ord time xor chr undef and eval caller and\nprintf srand lstat chown chdir syscall open select\neq -w closedir sleep chr split and quotemeta reset\nrequire ne closedir sleep chr undef or pack unpack\nlength study length umask readpipe pos xor defined\n join system and die or do exit if defined require\nhex defined undef or sprintf localtime cmp time or\nabs time and undef and open exp getc fileno system\ncaller eof rewinddir readpipe return study defined\nkill die wantarray and readlink eof readpipe split\neval warn join study abs localtime oct log time or\nreverse xor open 0; print chr ord while readline 0\n,;print chr abs length time for cos length defined\n"
  },
  {
    "path": "JAPH/japh_from_pod.pl",
    "content": "sub f{my%D;@D{@_}=();for(@_){if(-d){next if${_}eq'.';my@g;opendir(D,${_})||next;\nwhile(defined(my$d=readdir(D))){unless(${d}eq'.'or${d}eq'..'){push@g,\"${_}/$d\"}}\nclosedir(D);push@f,grep({-f}@g);f(grep((!exists($D{$_})),grep({-d}@g)))}elsif(-f\n){push@f,$_}}return@f}my$q=qr/[\"']\\w[^\\W\\d]{3}\\h\\w{5}([[:alpha:]])\\S\\b\\N\\D\\1\\w+?\n\\s\\p{PosixAlpha}\\B.[\\x63-\\x72]{4,},?(?:\\\\n)?[\"']/six;do{-T||next;open(_,'<',$_);\nsysread _,$_,-s;if(/$q/o){$_=eval$&;chomp;local$\\=$/;print;exit}}foreach(f@INC);\n"
  },
  {
    "path": "JAPH/japh_from_poetry.pl",
    "content": "$_ = q q\n       Jungla urbană si tonalitatea\n       amplifică naivitatea omului terestru, hrănind eficient răutatea...\n       Preoții explică răscumpărațiilor luciferului\n       hârtia acoperită cu koranul enunțat răului...\n\nq;for(split /\\s/){ print chr ord, q q q } print chr length time\n"
  },
  {
    "path": "JAPH/japh_from_punctuation_chars.pl",
    "content": "$,='@',$@=$,|'/',$:=$@,++$@,$@++,$~=(++$@,++$@),$.=$\",$_=$/|$,.((++$@,++$@).$~)\n.++$~.$..($;=$,|'!').($^='.'|$,).('/'|$,).$~.($@=$,|'(').($\"='%'|$,).(++$:=>,++\n$:,++$:).$..($:^'\"').$\".$:.(','|$,).$..$@.$;.($,.$,|'#+').$\".$:.','.$/=>=>print\n"
  },
  {
    "path": "JAPH/japh_from_subs.pl",
    "content": "print\"@{sub hacker;[grep{sub Just;$::{$_}eq-1}keys%::\n];sub Perl}[!!_+(++${sub another;_}),$?,//,$#$],$/\";;\n"
  },
  {
    "path": "JAPH/japh_from_the_deep.pl",
    "content": "\\&~=~'\\(';print+s{\\x42}{$\"}r,for($`..-$`)[4889245,650731,2540044,8375064,1505137],$/;\n"
  },
  {
    "path": "JAPH/japh_variable.pl",
    "content": "BEGIN{$^W=1,$SIG{__WARN__}=sub{pop=~s/:+([^\"]+)/die\n\"$1,$\\/\"=~tr\\_\\ \\r/error}}$Just_another_Perl_hacker\n"
  },
  {
    "path": "JAPH/japh_variables.pl",
    "content": "for($-..$=+$=){$_=chr;/[a-z]/io||next;$$_ = $_, $$_ = $_}\nprint \"$J$u$s$t $a$n$o$t$h$e$r $P$e$r$l $h$a$c$k$e$r,$/\";\n"
  },
  {
    "path": "JAPH/japh_variables_2.pl",
    "content": "$\\=$/;foreach($-..$=+$=){$_=chr,m$[\\x61-\\x75\\x2C]$i||next,$$_ = $_ and $$$_=$$_}\nprint join $\",$J.$u.$s.$t,$a.$n.$o.$t.$h.$e.$r,$P.$e.$r.$l,$h.$a.$c.$k.$e.$r.$,;\n"
  },
  {
    "path": "JAPH/leet_japh.pl",
    "content": "for(chr 97..chr 117){$_[@_]=$_}for$1(split/\\D/,<DATA>){$_.=$_\n[$1]if$_[$1]}s/([^Ja]+)([^p]+)([^h]+)(.+)/\\u$1 $2 \\u$3 $4,\\n/\n;@_=split//;for(@_){print;print\"\\0\"x6**$]if$^O=~/^l/}__DATA__\n9+20+18+19+23*0*13+14+19+7+4+17*15*4+17*11+7+0*2*10-4+17=1337\n"
  },
  {
    "path": "JAPH/length_obfuscation.pl",
    "content": "$_=q qrea ncJertsa ,thelhPkour q,my $i=length;\nwhile($i){s/(.{$i})(.)/$2$1/g;--$i}print+$_.$/\n"
  },
  {
    "path": "JAPH/log_japh.pl",
    "content": "print chr for unpack q((a2)*), substr log(18747683), 3, 8;\n"
  },
  {
    "path": "JAPH/log_japh_2.pl",
    "content": "use bignum;$\\=$/;$,=$\"; print map { pack \"C${\\(length>>1)}\", unpack\n\"x3(a2)*\", log } 51063670, 20632319030177, 54134528, 1100260138130;\n"
  },
  {
    "path": "JAPH/non-alphanumeric_japh.pl",
    "content": "$,='@',$@=$,|'/',$:=$@=>++$@,$@++,$~=(++$@=>/\\/\\//=>,++$@)=>$\\=(\"$,$,$,$,\"^\n'%#(/'),$_=($/|$,).((++$@,++$@).$~).++$~.$\".($;=$,|'!').($^=('.',=>,=>,)|$,\n).('/'|$,).$~.($@=$,|'(').($.='%'|$,).(++$:=>/<=|=>/=>,++$:=>++$:).$\".($:^+\n'\"').$..$:.(','|$,).$\".$@.$;.($,.$,|'#+').$..$:.',',`$\\ '$_'>&${\\($]>>//)}`\n"
  },
  {
    "path": "JAPH/re_eval_japh.pl",
    "content": "use re 'eval';\n_=~('(?{'.('[[).\\|`][[{[.@/(^.[{;\\,[@:?+^)('\n^'+)@@(^*((/[:@/[@;\\{+^.@{([\\@;[\"').'\"})');;\n"
  },
  {
    "path": "JAPH/slash_r_japh.pl",
    "content": "print$/=~s~~r~r=~s~~e~r=~s~~k~r=~s~~c~r=~s~~a~r=~s~~h~r=~s~~ ~r=~s<>\n~l~r=~s~~r~r=~s~~e~r=~s~~P~r=~s~~ ~r=~s~~r~r=~s~~e~r=~s~~h~r=~s~~t~r\n=~s~~o~r=~s~~n~r=~s~~a~r=~s~~ ~r=~s~~t~r=~s~~s~r=~s~~u~r=~s~~J~r////\n"
  },
  {
    "path": "JAPH/ternary_japh.pl",
    "content": "{{{{{{{{{{{{{{{{{{{{{{{{{$\\=$/}}}}}}}}}}}}}}}}}}}}}}}}}print\n'a'?'J':'b'?'c':'d'?'e':'f'?'g':'h'?'i':'j'?'k':'l'?'m':'n',\n'b'?'u':'c'?'d':'e'?'f':'g'?'h':'i'?'j':'k'?'l':'m'?'n':'o',\n'c'?'s':'d'?'e':'f'?'g':'h'?'i':'j'?'k':'l'?'m':'n'?'o':'p',\n'd'?'t':'e'?'f':'g'?'h':'i'?'j':'k'?'l':'m'?'n':'o'?'p':'q',\n'e'?' ':'f'?'g':'h'?'i':'j'?'k':'l'?'m':'n'?'o':'p'?'q':'r',\n'f'?'a':'g'?'h':'i'?'j':'k'?'l':'m'?'n':'o'?'p':'q'?'r':'s',\n'g'?'n':'h'?'i':'j'?'k':'l'?'m':'n'?'o':'p'?'q':'r'?'s':'t',\n'h'?'o':'i'?'j':'k'?'l':'m'?'n':'o'?'p':'q'?'r':'s'?'t':'u',\n'i'?'t':'j'?'k':'l'?'m':'n'?'o':'p'?'q':'r'?'s':'t'?'u':'v',\n'j'?'h':'k'?'l':'m'?'n':'o'?'p':'q'?'r':'s'?'t':'u'?'v':'w',\n'k'?'e':'l'?'m':'n'?'o':'p'?'q':'r'?'s':'t'?'u':'v'?'w':'x',\n'l'?'r':'m'?'n':'o'?'p':'q'?'r':'s'?'t':'u'?'v':'w'?'x':'y',\n'm'?' ':'n'?'o':'p'?'q':'r'?'s':'t'?'u':'v'?'w':'x'?'y':'z',\n'a'?'P':'b'?'c':'d'?'e':'f'?'g':'h'?'i':'j'?'k':'l'?'m':'n',\n'b'?'e':'c'?'d':'e'?'f':'g'?'h':'i'?'j':'k'?'l':'m'?'n':'o',\n'c'?'r':'d'?'e':'f'?'g':'h'?'i':'j'?'k':'l'?'m':'n'?'o':'p',\n'd'?'l':'e'?'f':'g'?'h':'i'?'j':'k'?'l':'m'?'n':'o'?'p':'q',\n'e'?' ':'f'?'g':'h'?'i':'j'?'k':'l'?'m':'n'?'o':'p'?'q':'r',\n'f'?'h':'g'?'h':'i'?'j':'k'?'l':'m'?'n':'o'?'p':'q'?'r':'s',\n'g'?'a':'h'?'i':'j'?'k':'l'?'m':'n'?'o':'p'?'q':'r'?'s':'t',\n'h'?'c':'i'?'j':'k'?'l':'m'?'n':'o'?'p':'q'?'r':'s'?'t':'u',\n'i'?'k':'j'?'k':'l'?'m':'n'?'o':'p'?'q':'r'?'s':'t'?'u':'v',\n'j'?'e':'k'?'l':'m'?'n':'o'?'p':'q'?'r':'s'?'t':'u'?'v':'w',\n'k'?'r':'l'?'m':'n'?'o':'p'?'q':'r'?'s':'t'?'u':'v'?'w':'x',\n'l'?',':'m'?'n':'o'?'p':'q'?'r':'s'?'t':'u'?'v':'w'?'x':'y';\n"
  },
  {
    "path": "JAPH/up_and_down.pl",
    "content": "eval {                                       hacker\n                                        Perl\n                                another\n                           Just\n$,=$\"};\neval {                     Just\n                                another\n                                        Perl\n                                             hacker\n};\npackage                         another\n;sub                       Just\n{print qw;                              Perl\n                                             hacker\n;}\npackage                                      hacker\n;sub                                    Perl\n{print qw;                 Just\n                                another\n;,''}\n"
  },
  {
    "path": "JAPH/vec_japh.pl",
    "content": "$_ = [\n        74, 116, 113, 113,\n        28,  92, 104, 104,\n       108,  95,  91, 103,\n        20,  67,  87,  99,\n        92,  15,  86,  78,\n        79,  86,  79,  91,\n        20,  19,  00,  73,\n     ];\n\n{vec(${print${$j},$/;$j},$i++\n,8)=$$_[$i]+$i;$$_[$i]&&redo}\n"
  },
  {
    "path": "JAPH/vec_japh_2.pl",
    "content": "$_=[$j=#];\n          101,  98, 102, 108, 28,\n           69, 111, 108, 108, 23,\n           87,  99,  99, 103, 90,\n           86,  98,  15,  62, 82,\n           94,  87,  10,  81, 73,\n           74,  81,  74,  86, 15,\n            2,  31,   6,  17,  0,\n$i=$j-$j];\n\n{vec($j,$i++,8)=$$_[$i]+$i;$$_[$i]&&redo||`$j`}\n"
  },
  {
    "path": "LICENSE",
    "content": "GNU GENERAL PUBLIC LICENSE\n                       Version 3, 29 June 2007\n\n Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>\n Everyone is permitted to copy and distribute verbatim copies\n of this license document, but changing it is not allowed.\n\n                            Preamble\n\n  The GNU General Public License is a free, copyleft license for\nsoftware and other kinds of works.\n\n  The licenses for most software and other practical works are designed\nto take away your freedom to share and change the works.  By contrast,\nthe GNU General Public License is intended to guarantee your freedom to\nshare and change all versions of a program--to make sure it remains free\nsoftware for all its users.  We, the Free Software Foundation, use the\nGNU General Public License for most of our software; it applies also to\nany other work released this way by its authors.  You can apply it to\nyour programs, too.\n\n  When we speak of free software, we are referring to freedom, not\nprice.  Our General Public Licenses are designed to make sure that you\nhave the freedom to distribute copies of free software (and charge for\nthem if you wish), that you receive source code or can get it if you\nwant it, that you can change the software or use pieces of it in new\nfree programs, and that you know you can do these things.\n\n  To protect your rights, we need to prevent others from denying you\nthese rights or asking you to surrender the rights.  Therefore, you have\ncertain responsibilities if you distribute copies of the software, or if\nyou modify it: responsibilities to respect the freedom of others.\n\n  For example, if you distribute copies of such a program, whether\ngratis or for a fee, you must pass on to the recipients the same\nfreedoms that you received.  You must make sure that they, too, receive\nor can get the source code.  And you must show them these terms so they\nknow their rights.\n\n  Developers that use the GNU GPL protect your rights with two steps:\n(1) assert copyright on the software, and (2) offer you this License\ngiving you legal permission to copy, distribute and/or modify it.\n\n  For the developers' and authors' protection, the GPL clearly explains\nthat there is no warranty for this free software.  For both users' and\nauthors' sake, the GPL requires that modified versions be marked as\nchanged, so that their problems will not be attributed erroneously to\nauthors of previous versions.\n\n  Some devices are designed to deny users access to install or run\nmodified versions of the software inside them, although the manufacturer\ncan do so.  This is fundamentally incompatible with the aim of\nprotecting users' freedom to change the software.  The systematic\npattern of such abuse occurs in the area of products for individuals to\nuse, which is precisely where it is most unacceptable.  Therefore, we\nhave designed this version of the GPL to prohibit the practice for those\nproducts.  If such problems arise substantially in other domains, we\nstand ready to extend this provision to those domains in future versions\nof the GPL, as needed to protect the freedom of users.\n\n  Finally, every program is threatened constantly by software patents.\nStates should not allow patents to restrict development and use of\nsoftware on general-purpose computers, but in those that do, we wish to\navoid the special danger that patents applied to a free program could\nmake it effectively proprietary.  To prevent this, the GPL assures that\npatents cannot be used to render the program non-free.\n\n  The precise terms and conditions for copying, distribution and\nmodification follow.\n\n                       TERMS AND CONDITIONS\n\n  0. Definitions.\n\n  \"This License\" refers to version 3 of the GNU General Public License.\n\n  \"Copyright\" also means copyright-like laws that apply to other kinds of\nworks, such as semiconductor masks.\n\n  \"The Program\" refers to any copyrightable work licensed under this\nLicense.  Each licensee is addressed as \"you\".  \"Licensees\" and\n\"recipients\" may be individuals or organizations.\n\n  To \"modify\" a work means to copy from or adapt all or part of the work\nin a fashion requiring copyright permission, other than the making of an\nexact copy.  The resulting work is called a \"modified version\" of the\nearlier work or a work \"based on\" the earlier work.\n\n  A \"covered work\" means either the unmodified Program or a work based\non the Program.\n\n  To \"propagate\" a work means to do anything with it that, without\npermission, would make you directly or secondarily liable for\ninfringement under applicable copyright law, except executing it on a\ncomputer or modifying a private copy.  Propagation includes copying,\ndistribution (with or without modification), making available to the\npublic, and in some countries other activities as well.\n\n  To \"convey\" a work means any kind of propagation that enables other\nparties to make or receive copies.  Mere interaction with a user through\na computer network, with no transfer of a copy, is not conveying.\n\n  An interactive user interface displays \"Appropriate Legal Notices\"\nto the extent that it includes a convenient and prominently visible\nfeature that (1) displays an appropriate copyright notice, and (2)\ntells the user that there is no warranty for the work (except to the\nextent that warranties are provided), that licensees may convey the\nwork under this License, and how to view a copy of this License.  If\nthe interface presents a list of user commands or options, such as a\nmenu, a prominent item in the list meets this criterion.\n\n  1. Source Code.\n\n  The \"source code\" for a work means the preferred form of the work\nfor making modifications to it.  \"Object code\" means any non-source\nform of a work.\n\n  A \"Standard Interface\" means an interface that either is an official\nstandard defined by a recognized standards body, or, in the case of\ninterfaces specified for a particular programming language, one that\nis widely used among developers working in that language.\n\n  The \"System Libraries\" of an executable work include anything, other\nthan the work as a whole, that (a) is included in the normal form of\npackaging a Major Component, but which is not part of that Major\nComponent, and (b) serves only to enable use of the work with that\nMajor Component, or to implement a Standard Interface for which an\nimplementation is available to the public in source code form.  A\n\"Major Component\", in this context, means a major essential component\n(kernel, window system, and so on) of the specific operating system\n(if any) on which the executable work runs, or a compiler used to\nproduce the work, or an object code interpreter used to run it.\n\n  The \"Corresponding Source\" for a work in object code form means all\nthe source code needed to generate, install, and (for an executable\nwork) run the object code and to modify the work, including scripts to\ncontrol those activities.  However, it does not include the work's\nSystem Libraries, or general-purpose tools or generally available free\nprograms which are used unmodified in performing those activities but\nwhich are not part of the work.  For example, Corresponding Source\nincludes interface definition files associated with source files for\nthe work, and the source code for shared libraries and dynamically\nlinked subprograms that the work is specifically designed to require,\nsuch as by intimate data communication or control flow between those\nsubprograms and other parts of the work.\n\n  The Corresponding Source need not include anything that users\ncan regenerate automatically from other parts of the Corresponding\nSource.\n\n  The Corresponding Source for a work in source code form is that\nsame work.\n\n  2. Basic Permissions.\n\n  All rights granted under this License are granted for the term of\ncopyright on the Program, and are irrevocable provided the stated\nconditions are met.  This License explicitly affirms your unlimited\npermission to run the unmodified Program.  The output from running a\ncovered work is covered by this License only if the output, given its\ncontent, constitutes a covered work.  This License acknowledges your\nrights of fair use or other equivalent, as provided by copyright law.\n\n  You may make, run and propagate covered works that you do not\nconvey, without conditions so long as your license otherwise remains\nin force.  You may convey covered works to others for the sole purpose\nof having them make modifications exclusively for you, or provide you\nwith facilities for running those works, provided that you comply with\nthe terms of this License in conveying all material for which you do\nnot control copyright.  Those thus making or running the covered works\nfor you must do so exclusively on your behalf, under your direction\nand control, on terms that prohibit them from making any copies of\nyour copyrighted material outside their relationship with you.\n\n  Conveying under any other circumstances is permitted solely under\nthe conditions stated below.  Sublicensing is not allowed; section 10\nmakes it unnecessary.\n\n  3. Protecting Users' Legal Rights From Anti-Circumvention Law.\n\n  No covered work shall be deemed part of an effective technological\nmeasure under any applicable law fulfilling obligations under article\n11 of the WIPO copyright treaty adopted on 20 December 1996, or\nsimilar laws prohibiting or restricting circumvention of such\nmeasures.\n\n  When you convey a covered work, you waive any legal power to forbid\ncircumvention of technological measures to the extent such circumvention\nis effected by exercising rights under this License with respect to\nthe covered work, and you disclaim any intention to limit operation or\nmodification of the work as a means of enforcing, against the work's\nusers, your or third parties' legal rights to forbid circumvention of\ntechnological measures.\n\n  4. Conveying Verbatim Copies.\n\n  You may convey verbatim copies of the Program's source code as you\nreceive it, in any medium, provided that you conspicuously and\nappropriately publish on each copy an appropriate copyright notice;\nkeep intact all notices stating that this License and any\nnon-permissive terms added in accord with section 7 apply to the code;\nkeep intact all notices of the absence of any warranty; and give all\nrecipients a copy of this License along with the Program.\n\n  You may charge any price or no price for each copy that you convey,\nand you may offer support or warranty protection for a fee.\n\n  5. Conveying Modified Source Versions.\n\n  You may convey a work based on the Program, or the modifications to\nproduce it from the Program, in the form of source code under the\nterms of section 4, provided that you also meet all of these conditions:\n\n    a) The work must carry prominent notices stating that you modified\n    it, and giving a relevant date.\n\n    b) The work must carry prominent notices stating that it is\n    released under this License and any conditions added under section\n    7.  This requirement modifies the requirement in section 4 to\n    \"keep intact all notices\".\n\n    c) You must license the entire work, as a whole, under this\n    License to anyone who comes into possession of a copy.  This\n    License will therefore apply, along with any applicable section 7\n    additional terms, to the whole of the work, and all its parts,\n    regardless of how they are packaged.  This License gives no\n    permission to license the work in any other way, but it does not\n    invalidate such permission if you have separately received it.\n\n    d) If the work has interactive user interfaces, each must display\n    Appropriate Legal Notices; however, if the Program has interactive\n    interfaces that do not display Appropriate Legal Notices, your\n    work need not make them do so.\n\n  A compilation of a covered work with other separate and independent\nworks, which are not by their nature extensions of the covered work,\nand which are not combined with it such as to form a larger program,\nin or on a volume of a storage or distribution medium, is called an\n\"aggregate\" if the compilation and its resulting copyright are not\nused to limit the access or legal rights of the compilation's users\nbeyond what the individual works permit.  Inclusion of a covered work\nin an aggregate does not cause this License to apply to the other\nparts of the aggregate.\n\n  6. Conveying Non-Source Forms.\n\n  You may convey a covered work in object code form under the terms\nof sections 4 and 5, provided that you also convey the\nmachine-readable Corresponding Source under the terms of this License,\nin one of these ways:\n\n    a) Convey the object code in, or embodied in, a physical product\n    (including a physical distribution medium), accompanied by the\n    Corresponding Source fixed on a durable physical medium\n    customarily used for software interchange.\n\n    b) Convey the object code in, or embodied in, a physical product\n    (including a physical distribution medium), accompanied by a\n    written offer, valid for at least three years and valid for as\n    long as you offer spare parts or customer support for that product\n    model, to give anyone who possesses the object code either (1) a\n    copy of the Corresponding Source for all the software in the\n    product that is covered by this License, on a durable physical\n    medium customarily used for software interchange, for a price no\n    more than your reasonable cost of physically performing this\n    conveying of source, or (2) access to copy the\n    Corresponding Source from a network server at no charge.\n\n    c) Convey individual copies of the object code with a copy of the\n    written offer to provide the Corresponding Source.  This\n    alternative is allowed only occasionally and noncommercially, and\n    only if you received the object code with such an offer, in accord\n    with subsection 6b.\n\n    d) Convey the object code by offering access from a designated\n    place (gratis or for a charge), and offer equivalent access to the\n    Corresponding Source in the same way through the same place at no\n    further charge.  You need not require recipients to copy the\n    Corresponding Source along with the object code.  If the place to\n    copy the object code is a network server, the Corresponding Source\n    may be on a different server (operated by you or a third party)\n    that supports equivalent copying facilities, provided you maintain\n    clear directions next to the object code saying where to find the\n    Corresponding Source.  Regardless of what server hosts the\n    Corresponding Source, you remain obligated to ensure that it is\n    available for as long as needed to satisfy these requirements.\n\n    e) Convey the object code using peer-to-peer transmission, provided\n    you inform other peers where the object code and Corresponding\n    Source of the work are being offered to the general public at no\n    charge under subsection 6d.\n\n  A separable portion of the object code, whose source code is excluded\nfrom the Corresponding Source as a System Library, need not be\nincluded in conveying the object code work.\n\n  A \"User Product\" is either (1) a \"consumer product\", which means any\ntangible personal property which is normally used for personal, family,\nor household purposes, or (2) anything designed or sold for incorporation\ninto a dwelling.  In determining whether a product is a consumer product,\ndoubtful cases shall be resolved in favor of coverage.  For a particular\nproduct received by a particular user, \"normally used\" refers to a\ntypical or common use of that class of product, regardless of the status\nof the particular user or of the way in which the particular user\nactually uses, or expects or is expected to use, the product.  A product\nis a consumer product regardless of whether the product has substantial\ncommercial, industrial or non-consumer uses, unless such uses represent\nthe only significant mode of use of the product.\n\n  \"Installation Information\" for a User Product means any methods,\nprocedures, authorization keys, or other information required to install\nand execute modified versions of a covered work in that User Product from\na modified version of its Corresponding Source.  The information must\nsuffice to ensure that the continued functioning of the modified object\ncode is in no case prevented or interfered with solely because\nmodification has been made.\n\n  If you convey an object code work under this section in, or with, or\nspecifically for use in, a User Product, and the conveying occurs as\npart of a transaction in which the right of possession and use of the\nUser Product is transferred to the recipient in perpetuity or for a\nfixed term (regardless of how the transaction is characterized), the\nCorresponding Source conveyed under this section must be accompanied\nby the Installation Information.  But this requirement does not apply\nif neither you nor any third party retains the ability to install\nmodified object code on the User Product (for example, the work has\nbeen installed in ROM).\n\n  The requirement to provide Installation Information does not include a\nrequirement to continue to provide support service, warranty, or updates\nfor a work that has been modified or installed by the recipient, or for\nthe User Product in which it has been modified or installed.  Access to a\nnetwork may be denied when the modification itself materially and\nadversely affects the operation of the network or violates the rules and\nprotocols for communication across the network.\n\n  Corresponding Source conveyed, and Installation Information provided,\nin accord with this section must be in a format that is publicly\ndocumented (and with an implementation available to the public in\nsource code form), and must require no special password or key for\nunpacking, reading or copying.\n\n  7. Additional Terms.\n\n  \"Additional permissions\" are terms that supplement the terms of this\nLicense by making exceptions from one or more of its conditions.\nAdditional permissions that are applicable to the entire Program shall\nbe treated as though they were included in this License, to the extent\nthat they are valid under applicable law.  If additional permissions\napply only to part of the Program, that part may be used separately\nunder those permissions, but the entire Program remains governed by\nthis License without regard to the additional permissions.\n\n  When you convey a copy of a covered work, you may at your option\nremove any additional permissions from that copy, or from any part of\nit.  (Additional permissions may be written to require their own\nremoval in certain cases when you modify the work.)  You may place\nadditional permissions on material, added by you to a covered work,\nfor which you have or can give appropriate copyright permission.\n\n  Notwithstanding any other provision of this License, for material you\nadd to a covered work, you may (if authorized by the copyright holders of\nthat material) supplement the terms of this License with terms:\n\n    a) Disclaiming warranty or limiting liability differently from the\n    terms of sections 15 and 16 of this License; or\n\n    b) Requiring preservation of specified reasonable legal notices or\n    author attributions in that material or in the Appropriate Legal\n    Notices displayed by works containing it; or\n\n    c) Prohibiting misrepresentation of the origin of that material, or\n    requiring that modified versions of such material be marked in\n    reasonable ways as different from the original version; or\n\n    d) Limiting the use for publicity purposes of names of licensors or\n    authors of the material; or\n\n    e) Declining to grant rights under trademark law for use of some\n    trade names, trademarks, or service marks; or\n\n    f) Requiring indemnification of licensors and authors of that\n    material by anyone who conveys the material (or modified versions of\n    it) with contractual assumptions of liability to the recipient, for\n    any liability that these contractual assumptions directly impose on\n    those licensors and authors.\n\n  All other non-permissive additional terms are considered \"further\nrestrictions\" within the meaning of section 10.  If the Program as you\nreceived it, or any part of it, contains a notice stating that it is\ngoverned by this License along with a term that is a further\nrestriction, you may remove that term.  If a license document contains\na further restriction but permits relicensing or conveying under this\nLicense, you may add to a covered work material governed by the terms\nof that license document, provided that the further restriction does\nnot survive such relicensing or conveying.\n\n  If you add terms to a covered work in accord with this section, you\nmust place, in the relevant source files, a statement of the\nadditional terms that apply to those files, or a notice indicating\nwhere to find the applicable terms.\n\n  Additional terms, permissive or non-permissive, may be stated in the\nform of a separately written license, or stated as exceptions;\nthe above requirements apply either way.\n\n  8. Termination.\n\n  You may not propagate or modify a covered work except as expressly\nprovided under this License.  Any attempt otherwise to propagate or\nmodify it is void, and will automatically terminate your rights under\nthis License (including any patent licenses granted under the third\nparagraph of section 11).\n\n  However, if you cease all violation of this License, then your\nlicense from a particular copyright holder is reinstated (a)\nprovisionally, unless and until the copyright holder explicitly and\nfinally terminates your license, and (b) permanently, if the copyright\nholder fails to notify you of the violation by some reasonable means\nprior to 60 days after the cessation.\n\n  Moreover, your license from a particular copyright holder is\nreinstated permanently if the copyright holder notifies you of the\nviolation by some reasonable means, this is the first time you have\nreceived notice of violation of this License (for any work) from that\ncopyright holder, and you cure the violation prior to 30 days after\nyour receipt of the notice.\n\n  Termination of your rights under this section does not terminate the\nlicenses of parties who have received copies or rights from you under\nthis License.  If your rights have been terminated and not permanently\nreinstated, you do not qualify to receive new licenses for the same\nmaterial under section 10.\n\n  9. Acceptance Not Required for Having Copies.\n\n  You are not required to accept this License in order to receive or\nrun a copy of the Program.  Ancillary propagation of a covered work\noccurring solely as a consequence of using peer-to-peer transmission\nto receive a copy likewise does not require acceptance.  However,\nnothing other than this License grants you permission to propagate or\nmodify any covered work.  These actions infringe copyright if you do\nnot accept this License.  Therefore, by modifying or propagating a\ncovered work, you indicate your acceptance of this License to do so.\n\n  10. Automatic Licensing of Downstream Recipients.\n\n  Each time you convey a covered work, the recipient automatically\nreceives a license from the original licensors, to run, modify and\npropagate that work, subject to this License.  You are not responsible\nfor enforcing compliance by third parties with this License.\n\n  An \"entity transaction\" is a transaction transferring control of an\norganization, or substantially all assets of one, or subdividing an\norganization, or merging organizations.  If propagation of a covered\nwork results from an entity transaction, each party to that\ntransaction who receives a copy of the work also receives whatever\nlicenses to the work the party's predecessor in interest had or could\ngive under the previous paragraph, plus a right to possession of the\nCorresponding Source of the work from the predecessor in interest, if\nthe predecessor has it or can get it with reasonable efforts.\n\n  You may not impose any further restrictions on the exercise of the\nrights granted or affirmed under this License.  For example, you may\nnot impose a license fee, royalty, or other charge for exercise of\nrights granted under this License, and you may not initiate litigation\n(including a cross-claim or counterclaim in a lawsuit) alleging that\nany patent claim is infringed by making, using, selling, offering for\nsale, or importing the Program or any portion of it.\n\n  11. Patents.\n\n  A \"contributor\" is a copyright holder who authorizes use under this\nLicense of the Program or a work on which the Program is based.  The\nwork thus licensed is called the contributor's \"contributor version\".\n\n  A contributor's \"essential patent claims\" are all patent claims\nowned or controlled by the contributor, whether already acquired or\nhereafter acquired, that would be infringed by some manner, permitted\nby this License, of making, using, or selling its contributor version,\nbut do not include claims that would be infringed only as a\nconsequence of further modification of the contributor version.  For\npurposes of this definition, \"control\" includes the right to grant\npatent sublicenses in a manner consistent with the requirements of\nthis License.\n\n  Each contributor grants you a non-exclusive, worldwide, royalty-free\npatent license under the contributor's essential patent claims, to\nmake, use, sell, offer for sale, import and otherwise run, modify and\npropagate the contents of its contributor version.\n\n  In the following three paragraphs, a \"patent license\" is any express\nagreement or commitment, however denominated, not to enforce a patent\n(such as an express permission to practice a patent or covenant not to\nsue for patent infringement).  To \"grant\" such a patent license to a\nparty means to make such an agreement or commitment not to enforce a\npatent against the party.\n\n  If you convey a covered work, knowingly relying on a patent license,\nand the Corresponding Source of the work is not available for anyone\nto copy, free of charge and under the terms of this License, through a\npublicly available network server or other readily accessible means,\nthen you must either (1) cause the Corresponding Source to be so\navailable, or (2) arrange to deprive yourself of the benefit of the\npatent license for this particular work, or (3) arrange, in a manner\nconsistent with the requirements of this License, to extend the patent\nlicense to downstream recipients.  \"Knowingly relying\" means you have\nactual knowledge that, but for the patent license, your conveying the\ncovered work in a country, or your recipient's use of the covered work\nin a country, would infringe one or more identifiable patents in that\ncountry that you have reason to believe are valid.\n\n  If, pursuant to or in connection with a single transaction or\narrangement, you convey, or propagate by procuring conveyance of, a\ncovered work, and grant a patent license to some of the parties\nreceiving the covered work authorizing them to use, propagate, modify\nor convey a specific copy of the covered work, then the patent license\nyou grant is automatically extended to all recipients of the covered\nwork and works based on it.\n\n  A patent license is \"discriminatory\" if it does not include within\nthe scope of its coverage, prohibits the exercise of, or is\nconditioned on the non-exercise of one or more of the rights that are\nspecifically granted under this License.  You may not convey a covered\nwork if you are a party to an arrangement with a third party that is\nin the business of distributing software, under which you make payment\nto the third party based on the extent of your activity of conveying\nthe work, and under which the third party grants, to any of the\nparties who would receive the covered work from you, a discriminatory\npatent license (a) in connection with copies of the covered work\nconveyed by you (or copies made from those copies), or (b) primarily\nfor and in connection with specific products or compilations that\ncontain the covered work, unless you entered into that arrangement,\nor that patent license was granted, prior to 28 March 2007.\n\n  Nothing in this License shall be construed as excluding or limiting\nany implied license or other defenses to infringement that may\notherwise be available to you under applicable patent law.\n\n  12. No Surrender of Others' Freedom.\n\n  If conditions are imposed on you (whether by court order, agreement or\notherwise) that contradict the conditions of this License, they do not\nexcuse you from the conditions of this License.  If you cannot convey a\ncovered work so as to satisfy simultaneously your obligations under this\nLicense and any other pertinent obligations, then as a consequence you may\nnot convey it at all.  For example, if you agree to terms that obligate you\nto collect a royalty for further conveying from those to whom you convey\nthe Program, the only way you could satisfy both those terms and this\nLicense would be to refrain entirely from conveying the Program.\n\n  13. Use with the GNU Affero General Public License.\n\n  Notwithstanding any other provision of this License, you have\npermission to link or combine any covered work with a work licensed\nunder version 3 of the GNU Affero General Public License into a single\ncombined work, and to convey the resulting work.  The terms of this\nLicense will continue to apply to the part which is the covered work,\nbut the special requirements of the GNU Affero General Public License,\nsection 13, concerning interaction through a network will apply to the\ncombination as such.\n\n  14. Revised Versions of this License.\n\n  The Free Software Foundation may publish revised and/or new versions of\nthe GNU General Public License from time to time.  Such new versions will\nbe similar in spirit to the present version, but may differ in detail to\naddress new problems or concerns.\n\n  Each version is given a distinguishing version number.  If the\nProgram specifies that a certain numbered version of the GNU General\nPublic License \"or any later version\" applies to it, you have the\noption of following the terms and conditions either of that numbered\nversion or of any later version published by the Free Software\nFoundation.  If the Program does not specify a version number of the\nGNU General Public License, you may choose any version ever published\nby the Free Software Foundation.\n\n  If the Program specifies that a proxy can decide which future\nversions of the GNU General Public License can be used, that proxy's\npublic statement of acceptance of a version permanently authorizes you\nto choose that version for the Program.\n\n  Later license versions may give you additional or different\npermissions.  However, no additional obligations are imposed on any\nauthor or copyright holder as a result of your choosing to follow a\nlater version.\n\n  15. Disclaimer of Warranty.\n\n  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY\nAPPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT\nHOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY\nOF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,\nTHE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR\nPURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM\nIS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF\nALL NECESSARY SERVICING, REPAIR OR CORRECTION.\n\n  16. Limitation of Liability.\n\n  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING\nWILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS\nTHE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY\nGENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE\nUSE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF\nDATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD\nPARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),\nEVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF\nSUCH DAMAGES.\n\n  17. Interpretation of Sections 15 and 16.\n\n  If the disclaimer of warranty and limitation of liability provided\nabove cannot be given local legal effect according to their terms,\nreviewing courts shall apply local law that most closely approximates\nan absolute waiver of all civil liability in connection with the\nProgram, unless a warranty or assumption of liability accompanies a\ncopy of the Program in return for a fee.\n\n                     END OF TERMS AND CONDITIONS\n\n            How to Apply These Terms to Your New Programs\n\n  If you develop a new program, and you want it to be of the greatest\npossible use to the public, the best way to achieve this is to make it\nfree software which everyone can redistribute and change under these terms.\n\n  To do so, attach the following notices to the program.  It is safest\nto attach them to the start of each source file to most effectively\nstate the exclusion of warranty; and each file should have at least\nthe \"copyright\" line and a pointer to where the full notice is found.\n\n    {one line to give the program's name and a brief idea of what it does.}\n    Copyright (C) {year}  {name of author}\n\n    This program is free software: you can redistribute it and/or modify\n    it under the terms of the GNU General Public License as published by\n    the Free Software Foundation, either version 3 of the License, or\n    (at your option) any later version.\n\n    This program is distributed in the hope that it will be useful,\n    but WITHOUT ANY WARRANTY; without even the implied warranty of\n    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n    GNU General Public License for more details.\n\n    You should have received a copy of the GNU General Public License\n    along with this program.  If not, see <https://www.gnu.org/licenses/>.\n\nAlso add information on how to contact you by electronic and paper mail.\n\n  If the program does terminal interaction, make it output a short\nnotice like this when it starts in an interactive mode:\n\n    {project}  Copyright (C) {year}  {fullname}\n    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.\n    This is free software, and you are welcome to redistribute it\n    under certain conditions; type `show c' for details.\n\nThe hypothetical commands `show w' and `show c' should show the appropriate\nparts of the General Public License.  Of course, your program's commands\nmight be different; for a GUI interface, you would use an \"about box\".\n\n  You should also get your employer (if you work as a programmer) or school,\nif any, to sign a \"copyright disclaimer\" for the program, if necessary.\nFor more information on this, and how to apply and follow the GNU GPL, see\n<https://www.gnu.org/licenses/>.\n\n  The GNU General Public License does not permit incorporating your program\ninto proprietary programs.  If your program is a subroutine library, you\nmay consider it more useful to permit linking proprietary applications with\nthe library.  If this is what you want to do, use the GNU Lesser General\nPublic License instead of this License.  But first, please read\n<https://www.gnu.org/philosophy/why-not-lgpl.html>.\n"
  },
  {
    "path": "Lingua/en_phoneme.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# License: GPLv3\n# Date: 15 April 2014\n# Website: https://github.com/trizen\n\n# usage: ./en_phoneme.pl [word] [word] [...]\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Lingua::EN::Phoneme;\nmy $lep = Lingua::EN::Phoneme->new;\n\nsub normalize {\n    my $syl = lc($_[0]);\n    $syl =~ s/h0\\z/x/;\n    $syl =~ s/\\w\\K0\\z//;\n    $syl =~ s/\\w\\K1\\z//;\n    return $syl;\n}\n\nforeach my $word (@ARGV) {\n    my $p_word = $lep->phoneme($word) // do {\n        warn \"error: '$word' is not an English word!\\n\";\n        next;\n    };\n    say join(\" \", map { normalize($_) } split(' ', $p_word));\n}\n"
  },
  {
    "path": "Lingua/lingua_ro_numbers.pl",
    "content": "#!/usr/bin/perl\n\nuse utf8;\nuse 5.014;\nuse strict;\nuse warnings;\n\nuse open ':std' => 'utf8';\n\nuse Scalar::Util qw(looks_like_number);\nuse Lingua::RO::Numbers qw(ro_to_number number_to_ro);\n\nrequire Term::ReadLine;\nmy $term = Term::ReadLine->new($0);\n\nwhile (1) {\n    my $num = $term->readline(\"Introduceți un număr: \") // last;\n    say +(looks_like_number($num) ? number_to_ro($num) : ro_to_number($num)) // next;\n}\n"
  },
  {
    "path": "Lingua/poetry_from_poetry.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 09 February 2017\n# https://github.com/trizen\n\n# An experimental poetry generator, using a given poetry\n# as input, replacing words with other similar words.\n\n# usage:\n#   perl poetry_from_poetry.pl [poetry.txt] [wordlists]\n\nuse 5.016;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse open IO => ':utf8', ':std';\n\nuse File::Find qw(find);\n\nmy $poetry_file = shift(@ARGV);\n\n@ARGV\n  || die \"usage: $0 [poetry.txt] [wordlists]\\n\";\n\nmy $poetry = do {\n    open my $fh, '<', $poetry_file;\n    local $/;\n    <$fh>;\n};\n\nmy $starting_len = 2;    # word starting length\nmy $ending_len   = 2;    # word ending length\n\nmy %words;\nmy %seen;\n\nsub generate_key {\n    my ($word) = @_;\n    substr($word, 0, $starting_len) . substr($word, -$ending_len);\n}\n\nsub collect_words {\n    my ($file) = @_;\n\n    open my $fh, '<', $file;\n\n    my $content = do {\n        local $/;\n        <$fh>;\n    };\n\n    close $fh;\n\n    while ($content =~ /([\\pL]+)/g) {\n        my $word = CORE::fc($1);\n        if (length($word) > $ending_len) {\n            next if $seen{$word}++;\n            my $key = generate_key($word);\n            push @{$words{$key}}, $word;\n        }\n    }\n}\n\nfind {\n    no_chdir => 1,\n    wanted   => sub {\n        if ((-f $_) and (-T _)) {\n            collect_words($_);\n        }\n    },\n} => @ARGV;\n\n$poetry =~ s{([\\pL]+)}{\n    my $word = $1;\n    if (length($word) <= $ending_len) {\n        $word;\n    }\n    else {\n        my $key = generate_key($word);\n        exists($words{$key}) ? $words{$key}[rand @{$words{$key}}] : $word;\n    }\n}ge;\n\nsay $poetry;\n"
  },
  {
    "path": "Lingua/poetry_from_poetry_with_variations.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 09 February 2017\n# https://github.com/trizen\n\n# An experimental poetry generator, using a given poetry as input,\n# replacing words with random words from groups of alike ending words.\n\n# usage:\n#   perl poetry_from_poetry.pl [poetry.txt] [wordlists]\n\nuse 5.016;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse open IO => ':utf8', ':std';\n\nuse File::Find qw(find);\n\nmy $poetry_file = shift(@ARGV);\n\n@ARGV\n  || die \"usage: $0 [poetry.txt] [wordlists]\\n\";\n\nmy $poetry = do {\n    open my $fh, '<', $poetry_file;\n    local $/;\n    <$fh>;\n};\n\nmy $ending_len = 3;    # word ending length\nmy $group_len  = 0;    # the number of words in a group - 1\n\nmy $word_regex = qr/[\\pL]+(?:-[\\pL]+)?/;\n\nmy %words;\nmy %seen;\n\nsub collect_words {\n    my ($file) = @_;\n\n    open my $fh, '<', $file;\n\n    my $content = do {\n        local $/;\n        <$fh>;\n    };\n\n    close $fh;\n\n    while ($content =~ /($word_regex(?:\\h+$word_regex){$group_len})/go) {\n        my $word = CORE::fc($1);\n        my $len = $ending_len;\n\n        if (length($word) > $len) {\n            next if $seen{$word}++;\n            push @{$words{substr($word, -$len)}}, $word;\n        }\n    }\n}\n\nfind {\n    no_chdir => 1,\n    wanted   => sub {\n        if ((-f $_) and (-T _)) {\n            collect_words($_);\n        }\n    },\n} => @ARGV;\n\nmy @keys = keys(%words);\nmy %endings;\n\n$poetry =~ s{($word_regex)}{\n    my $word = $1;\n    my $len = $ending_len;\n\n    if (length($word) <= $len) {\n        $word;\n    }\n    else {\n        my $ending = CORE::fc(substr($word, -$len));\n        my $key = ($endings{$ending} //= $keys[rand @keys]);\n        exists($words{$key}) ? $words{$key}[rand @{$words{$key}}] : $word;\n    }\n}ge;\n\nsay $poetry;\n"
  },
  {
    "path": "Lingua/random_poetry_generator.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 09 February 2017\n# https://github.com/trizen\n\n# An experimental random poetry generator.\n\n# usage:\n#   perl random_poetry_generator.pl [wordlist]\n\nuse 5.016;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse open IO => ':utf8', ':std';\n\nuse List::Util qw(max);\nuse File::Find qw(find);\n\n@ARGV || die \"usage: $0 [wordlists]\\n\";    # wordlists or directories\n\nmy $min_len     = 20;                      # minimum length of each verse\nmy $ending_len  = 3;                       # rhyme ending length\nmy $strophe_len = 4;                       # number of verses in a strophe\n\n#<<<\n# Rhymes template\nmy @template = (\n    'A', 'A', 'B', 'B',\n    'A', 'B', 'B', 'A',\n    'A', 'B', 'A', 'B',\n    'B', 'A', 'A', 'B',\n);\n#>>>\n\nmy $max_endings = do {\n    my %count;\n    ++$count{$_} for @template;\n    max(values %count);\n};\n\nmy %words;\nmy %seen;\n\nsub collect_words {\n    my ($file) = @_;\n\n    open my $fh, '<', $file;\n\n    my $content = do {\n        local $/;\n        <$fh>;\n    };\n\n    close $fh;\n\n    my @words =\n      grep { length($_) > $ending_len }\n      map  { CORE::fc(s/^[^\\pL]+//r =~ s/[^\\pL]+\\z//r) }\n      split(' ', $content);\n\n    foreach my $word (@words) {\n        next if $seen{$word}++;\n        push @{$words{substr($word, -$ending_len)}}, $word;\n    }\n}\n\nfind {\n    no_chdir => 1,\n    wanted   => sub {\n        if ((-f $_) and (-T _)) {\n            collect_words($_);\n        }\n    },\n} => @ARGV;\n\nmy @keys = keys(%words);\n\nmy %endings;\nmy %used_ending;\nmy %used_word;\n\nmy $strofhe_i = 0;\nforeach my $r (@template) {\n    my $ending;\n\n    if (exists $endings{$r}) {\n        $ending = $endings{$r};\n    }\n    else {\n        my $try = 0;\n        do {\n            $ending = $keys[rand @keys];\n        } while (@{$words{$ending}} < $max_endings and !exists($used_ending{$ending}) and ++$try < 1000);\n        $endings{$r}          = $ending;\n        $used_ending{$ending} = 1;\n    }\n\n    my @row;\n\n    for (my $length = 0 ; ;) {\n\n        my $word;\n        my $try = 0;\n        do {\n            my $key = ($length > $min_len) ? $ending : $keys[rand @keys];\n            my $words = $words{$key};\n            $word = $words->[rand @$words];\n        } while (exists($used_word{$word}) and ++$try < 1000);\n\n        $used_word{$word} = 1;\n\n        push @row, $word;\n        last if $length > $min_len;\n        $length += length($word) + 1;\n    }\n\n    say \"@row\";\n    print \"\\n\" if (++$strofhe_i % $strophe_len == 0);\n}\n"
  },
  {
    "path": "Lingua/rus_translit.pl",
    "content": "use Lingua::Translit;\nmy $tr = new Lingua::Translit('DIN 1460 RUS');\nprint $tr->translit(@ARGV ? shift : join'',<>);\n"
  },
  {
    "path": "Math/1_over_n_is_finite.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 25 December 2012\n# https://github.com/trizen\n\n# Checks if 1/n is finite or infinite.\n\n# See also: https://perlmonks.org/index.pl?node_id=1006283\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub is_finite {\n    my ($x) = @_;\n    $x || return;\n    $x /= 5 while $x % 5 == 0;\n    return !($x & $x - 1);\n}\n\nforeach my $i (1 .. 20) {\n    printf \"%-4s is finite: %d\\n\", \"1/$i\", is_finite($i);\n}\n"
  },
  {
    "path": "Math/1_over_n_period_length.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 09 October 2016\n# Website: https://github.com/trizen\n\n# The period length after the decimal point of 1/n.\n# This is defined only for integers prime to 10.\n\n# Inspired by N. J. Wildberger's video:\n#   https://www.youtube.com/watch?v=lMrz7ISoDGs\n\n# See also:\n#   https://oeis.org/A002329\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(divisors euler_phi powmod);\n\nsub period_length_1_over_n {\n    my ($n) = @_;\n\n    my @divisors = divisors(euler_phi($n));\n\n    foreach my $d (@divisors) {\n        if (powmod(10, $d, $n) == 1) {\n            return $d;\n        }\n    }\n\n    return -1;\n}\n\nforeach my $n (1 .. 99) {\n    my $l = period_length_1_over_n($n);\n    printf(\"P(%2d) = %d\\n\", $n, $l) if $l != -1;\n}\n"
  },
  {
    "path": "Math/BPSW_primality_test.pl",
    "content": "#!/usr/bin/perl\n\n# The Baillie-PSW primality test, named after Robert Baillie, Carl Pomerance, John Selfridge, and Samuel Wagstaff.\n\n# No counter-examples are known to this test.\n\n# Algorithm: given an odd integer n, that is not a perfect power:\n#   1. Perform a (strong) base-2 Fermat test.\n#   2. Find the first D in the sequence 5, −7, 9, −11, 13, −15, ... for which the Jacobi symbol (D/n) is −1.\n#      Set P = 1 and Q = (1 − D) / 4.\n#   3. Perform a strong Lucas probable prime test on n using parameters D, P, and Q.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Lucas_pseudoprime\n#   https://en.wikipedia.org/wiki/Baillie%E2%80%93PSW_primality_test\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse Math::AnyNum qw(\n    is_prime is_power is_congruent\n    kronecker powmod as_bin bit_scan1\n);\n\nsub findQ($n) {\n\n    # Find first D for which kronecker(D, n) == -1\n    for (my $k = 2 ; ; ++$k) {\n        my $D = (-1)**$k * (2 * $k + 1);\n        if (kronecker($D, $n) == -1) {\n            return ((1 - $D) / 4);\n        }\n    }\n}\n\nsub BPSW_primality_test($n) {\n\n    return 0 if $n <= 1;\n    return 1 if $n == 2;\n\n    return 0 if !($n & 1);\n    return 0 if is_power($n);\n\n    # Fermat base-2 test\n    powmod(2, $n - 1, $n) == 1 or return 0;\n\n    # Perform a strong Lucas probable test\n    my $Q = findQ($n);\n    my $d = $n + 1;\n    my $s = bit_scan1($d, 0);\n    my $t = $d >> ($s+1);\n\n    my ($U1     ) = (1   );\n    my ($V1, $V2) = (2, 1);\n    my ($Q1, $Q2) = (1, 1);\n\n    foreach my $bit (split(//, as_bin($t))) {\n\n        $Q1 = ($Q1 * $Q2) % $n;\n\n        if ($bit) {\n            $Q2 = ($Q1 * $Q) % $n;\n            $U1 = ($U1 * $V2) % $n;\n            $V1 = ($V2 * $V1 - $Q1) % $n;\n            $V2 = ($V2 * $V2 - ($Q2 + $Q2)) % $n;\n        }\n        else {\n            $Q2 = $Q1;\n            $U1 = ($U1 * $V1 - $Q1) % $n;\n            $V2 = ($V2 * $V1 - $Q1) % $n;\n            $V1 = ($V1 * $V1 - ($Q2 + $Q2)) % $n;\n        }\n    }\n\n    $Q1 = ($Q1 * $Q2) % $n;\n    $Q2 = ($Q1 * $Q) % $n;\n    $U1 = ($U1 * $V1 - $Q1) % $n;\n    $V1 = ($V2 * $V1 - $Q1) % $n;\n    $Q1 = ($Q1 * $Q2) % $n;\n\n    return 1 if is_congruent($U1, 0, $n);\n    return 1 if is_congruent($V1, 0, $n);\n\n    for (1 .. $s-1) {\n\n        $V1 = ($V1 * $V1 - 2 * $Q1) % $n;\n        $Q1 = ($Q1 * $Q1) % $n;\n\n        return 1 if is_congruent($V1, 0, $n);\n    }\n\n    return 0;\n}\n\n#\n## Run some tests\n#\n\nmy $from  = 1;\nmy $to    = 1e5;\nmy $count = 0;\n\nforeach my $n ($from .. $to) {\n    if (BPSW_primality_test($n)) {\n        if (not is_prime($n)) {\n            say \"Counter-example: $n\";\n        }\n        ++$count;\n    }\n    elsif (is_prime($n)) {\n        say \"Missed a prime: $n\";\n    }\n}\n\nsay \"There are $count primes between $from and $to.\";\n"
  },
  {
    "path": "Math/BPSW_primality_test_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# The Baillie-PSW primality test, named after Robert Baillie, Carl Pomerance, John Selfridge, and Samuel Wagstaff.\n\n# No counter-examples are known to this test.\n\n# Algorithm: given an odd integer n, that is not a perfect power:\n#   1. Perform a (strong) base-2 Fermat test.\n#   2. Find the first D in the sequence 5, −7, 9, −11, 13, −15, ... for which the Jacobi symbol (D/n) is −1.\n#      Set P = 1 and Q = (1 − D) / 4.\n#   3. Perform a strong Lucas probable prime test on n using parameters D, P, and Q.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Lucas_pseudoprime\n#   https://en.wikipedia.org/wiki/Baillie%E2%80%93PSW_primality_test\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse Math::GMPz;\n\nsub findQ ($n) {\n    for (my $k = 2 ; ; ++$k) {\n        my $D = (-1)**$k * (2 * $k + 1);\n\n        if (Math::GMPz::Rmpz_si_kronecker($D, $n) == -1) {\n            return ((1 - $D) / 4);\n        }\n    }\n}\n\nsub BPSW_primality_test ($n) {\n\n    $n = Math::GMPz::Rmpz_init_set_str($n, 10) if ref($n) ne 'Math::GMPz';\n\n    return 0 if Math::GMPz::Rmpz_cmp_ui($n, 1) <= 0;\n    return 1 if Math::GMPz::Rmpz_cmp_ui($n, 2) == 0;\n\n    return 0 if Math::GMPz::Rmpz_even_p($n);\n    return 0 if Math::GMPz::Rmpz_perfect_power_p($n);\n\n    state $d = Math::GMPz::Rmpz_init_nobless();\n    state $t = Math::GMPz::Rmpz_init_nobless();\n\n    Math::GMPz::Rmpz_set_ui($t, 2);\n\n    # Fermat base-2 test (a strong Miller-Rabin test should be preferred instead)\n    Math::GMPz::Rmpz_sub_ui($d, $n, 1);\n    Math::GMPz::Rmpz_powm($t, $t, $d, $n);\n    Math::GMPz::Rmpz_cmp_ui($t, 1) and return 0;\n\n    my $P = 1;\n    my $Q = findQ($n);\n\n    Math::GMPz::Rmpz_add_ui($d, $d, 2);                 # d = n+1\n    my $s = Math::GMPz::Rmpz_scan1($d, 0);              # s = valuation(n, 2)\n    Math::GMPz::Rmpz_div_2exp($t, $d, $s+1);            # t = d >> (s+1)\n\n    my $U1 = Math::GMPz::Rmpz_init_set_ui(1);\n    my ($V1, $V2) = (Math::GMPz::Rmpz_init_set_ui(2), Math::GMPz::Rmpz_init_set_ui($P));\n    my ($Q1, $Q2) = (Math::GMPz::Rmpz_init_set_ui(1), Math::GMPz::Rmpz_init_set_ui(1));\n\n    foreach my $bit (split(//, Math::GMPz::Rmpz_get_str($t, 2))) {\n\n        Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);\n        Math::GMPz::Rmpz_mod($Q1, $Q1, $n);\n\n        if ($bit) {\n            Math::GMPz::Rmpz_mul_si($Q2, $Q1, $Q);\n            Math::GMPz::Rmpz_mul($U1, $U1, $V2);\n            Math::GMPz::Rmpz_mul($V1, $V1, $V2);\n\n            Math::GMPz::Rmpz_powm_ui($V2, $V2, 2, $n);\n            Math::GMPz::Rmpz_sub($V1, $V1, $Q1);\n            Math::GMPz::Rmpz_submul_ui($V2, $Q2, 2);\n\n            Math::GMPz::Rmpz_mod($V1, $V1, $n);\n            Math::GMPz::Rmpz_mod($U1, $U1, $n);\n        }\n        else {\n            Math::GMPz::Rmpz_set($Q2, $Q1);\n            Math::GMPz::Rmpz_mul($U1, $U1, $V1);\n            Math::GMPz::Rmpz_mul($V2, $V2, $V1);\n            Math::GMPz::Rmpz_sub($U1, $U1, $Q1);\n\n            Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $n);\n            Math::GMPz::Rmpz_sub($V2, $V2, $Q1);\n            Math::GMPz::Rmpz_submul_ui($V1, $Q2, 2);\n\n            Math::GMPz::Rmpz_mod($V2, $V2, $n);\n            Math::GMPz::Rmpz_mod($U1, $U1, $n);\n        }\n    }\n\n    Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);\n    Math::GMPz::Rmpz_mul_si($Q2, $Q1, $Q);\n    Math::GMPz::Rmpz_mul($U1, $U1, $V1);\n    Math::GMPz::Rmpz_mul($V1, $V1, $V2);\n    Math::GMPz::Rmpz_sub($U1, $U1, $Q1);\n    Math::GMPz::Rmpz_sub($V1, $V1, $Q1);\n    Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);\n\n    if (Math::GMPz::Rmpz_divisible_p($U1, $n)) {\n        return 1;\n    }\n\n    if (Math::GMPz::Rmpz_divisible_p($V1, $n)) {\n        return 1;\n    }\n\n    for (1 .. $s-1) {\n\n        Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $n);\n        Math::GMPz::Rmpz_submul_ui($V1, $Q1, 2);\n        Math::GMPz::Rmpz_powm_ui($Q1, $Q1, 2, $n);\n\n        if (Math::GMPz::Rmpz_divisible_p($V1, $n)) {\n            return 1;\n        }\n    }\n\n    return 0;\n}\n\n#\n## Run some tests\n#\n\nuse ntheory qw(is_prime);\n\nmy $from  = 1;\nmy $to    = 1e5;\nmy $count = 0;\n\nforeach my $n ($from .. $to) {\n    if (BPSW_primality_test($n)) {\n        if (not is_prime($n)) {\n            say \"Counter-example: $n\";\n        }\n        ++$count;\n    }\n    elsif (is_prime($n)) {\n        say \"Missed a prime: $n\";\n    }\n}\n\nsay \"There are $count primes between $from and $to.\";\n"
  },
  {
    "path": "Math/LUP_decomposition.pl",
    "content": "#!/usr/bin/perl\n\n# Simple implementation of the LU decomposition.\n\n# See also:\n#   https://en.wikipedia.org/wiki/LU_decomposition\n\nuse 5.014;\nuse warnings;\n\nuse Math::AnyNum qw(:overload);\n\n# Code translated from Wikipedia (+ minor tweaks):\n#   https://en.wikipedia.org/wiki/LU_decomposition#C_code_examples\n\nsub _LUP_decompose {\n    my ($matrix) = @_;\n\n    my @A = map { [@$_] } @$matrix;\n    my $N = $#A;\n    my @P = (0 .. $N + 1);\n\n    foreach my $i (0 .. $N) {\n\n        my $maxA = 0;\n        my $imax = $i;\n\n        foreach my $k ($i .. $N) {\n            my $absA = abs($A[$k][$i] // return ($N, \\@A, \\@P));\n\n            if ($absA > $maxA) {\n                $maxA = $absA;\n                $imax = $k;\n            }\n        }\n\n        if ($imax != $i) {\n\n            @P[$i, $imax] = @P[$imax, $i];\n            @A[$i, $imax] = @A[$imax, $i];\n\n            ++$P[$N + 1];\n        }\n\n        foreach my $j ($i + 1 .. $N) {\n\n            if ($A[$i][$i] == 0) {\n                return ($N, \\@A, \\@P);\n            }\n\n            $A[$j][$i] /= $A[$i][$i];\n\n            foreach my $k ($i + 1 .. $N) {\n                $A[$j][$k] -= $A[$j][$i] * $A[$i][$k];\n            }\n        }\n    }\n\n    return ($N, \\@A, \\@P);\n}\n\nsub solve {\n    my ($matrix, $vector) = @_;\n\n    my ($N, $A, $P) = _LUP_decompose($matrix);\n\n    my @x = map { $vector->[$P->[$_]] } 0 .. $N;\n\n    foreach my $i (1 .. $N) {\n        foreach my $k (0 .. $i - 1) {\n            $x[$i] -= $A->[$i][$k] * $x[$k];\n        }\n    }\n\n    for (my $i = $N ; $i >= 0 ; --$i) {\n        foreach my $k ($i + 1 .. $N) {\n            $x[$i] -= $A->[$i][$k] * $x[$k];\n        }\n        $x[$i] /= $A->[$i][$i];\n    }\n\n    return \\@x;\n}\n\nsub invert {\n    my ($matrix) = @_;\n\n    my ($N, $A, $P) = _LUP_decompose($matrix);\n\n    my @I;\n\n    foreach my $j (0 .. $N) {\n        foreach my $i (0 .. $N) {\n\n            $I[$i][$j] = ($P->[$i] == $j) ? 1 : 0;\n\n            foreach my $k (0 .. $i - 1) {\n                $I[$i][$j] -= $A->[$i][$k] * $I[$k][$j];\n            }\n        }\n\n        for (my $i = $N ; $i >= 0 ; --$i) {\n\n            foreach my $k ($i + 1 .. $N) {\n                $I[$i][$j] -= $A->[$i][$k] * $I[$k][$j];\n            }\n\n            $I[$i][$j] /= $A->[$i][$i] // return [[]];\n        }\n    }\n\n    return \\@I;\n}\n\nsub determinant {\n    my ($matrix) = @_;\n\n    my ($N, $A, $P) = _LUP_decompose($matrix);\n\n    my $det = $A->[0][0] // return 1;\n\n    foreach my $i (1 .. $N) {\n        $det *= $A->[$i][$i];\n    }\n\n    if (($P->[$N + 1] - $N) % 2 == 0) {\n        $det *= -1;\n    }\n\n    return $det;\n}\n\n#\n## Examples\n#\n\n# Defining a matrix\n\nmy $A = [\n    [2, -1,  5,  1],\n    [3,  2,  2, -6],\n    [1,  3,  3, -1],\n    [5, -2, -3,  3],\n];\n\n# Determinant of a matrix\nsay \"det(A) = \", determinant($A);\n\n# Solve a system of linear equations\nmy $v = [-3, -32, -47, 49];\nsay '(', join(', ', @{solve($A, $v)}), ')';\n\n# Invert a matrix\nmy $inv = invert($A);\nsay join(\",\\n\", map { '[' . join(', ', map { sprintf('%8s', $_) } @$_) . ']' } @$inv);\n\n__END__\ndet(A) = 684\n\n(2, -12, -4, 1)\n\n[   4/171,   11/171,   10/171,     8/57],\n[ -55/342,  -23/342,  119/342,     2/57],\n[ 107/684,   -5/684,   11/684,   -7/114],\n[   7/684, -109/684,  103/684,    7/114]\n"
  },
  {
    "path": "Math/MBE_factorization_method.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 12 March 2022\n# https://github.com/trizen\n\n# A new integer factorization method, using the binary exponentiation algorithm with modular exponentiation.\n\n# We call it the \"Modular Binary Exponentiation\" (MBE) factorization method.\n\n# Similar in flavor to the Pollard's p-1 method.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Exponentiation_by_squaring\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::GMPz;\n\nsub MBE_factor ($n, $max_k = 1000) {\n\n    if (ref($n) ne 'Math::GMPz') {\n        $n = Math::GMPz->new(\"$n\");\n    }\n\n    my $t = Math::GMPz::Rmpz_init();\n    my $g = Math::GMPz::Rmpz_init();\n\n    my $a = Math::GMPz::Rmpz_init();\n    my $b = Math::GMPz::Rmpz_init();\n    my $c = Math::GMPz::Rmpz_init();\n\n    foreach my $k (1 .. $max_k) {\n\n        #say \"Trying k = $k\";\n\n        Math::GMPz::Rmpz_div_ui($t, $n, $k + 1);\n\n        Math::GMPz::Rmpz_set($a, $t);\n        Math::GMPz::Rmpz_set($b, $t);\n        Math::GMPz::Rmpz_set_ui($c, 1);\n\n        foreach my $i (0 .. Math::GMPz::Rmpz_sizeinbase($b, 2) - 1) {\n\n            if (Math::GMPz::Rmpz_tstbit($b, $i)) {\n\n                Math::GMPz::Rmpz_powm($c, $a, $c, $n);\n                Math::GMPz::Rmpz_sub_ui($g, $c, 1);\n                Math::GMPz::Rmpz_gcd($g, $g, $n);\n\n                if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0 and Math::GMPz::Rmpz_cmp($g, $n) < 0) {\n                    return $g;\n                }\n            }\n\n            Math::GMPz::Rmpz_powm($a, $a, $a, $n);\n        }\n    }\n\n    return;\n}\n\nsay MBE_factor(\"3034271543203\");                                    #=> 604727\nsay MBE_factor(\"43120971427631\");                                   #=> 5501281\nsay MBE_factor(\"1548517437362569\");                                 #=> 24970961\nsay MBE_factor(\"18446744073709551617\");                             #=> 274177\nsay MBE_factor(\"5889680315647781787273935275179391\");               #=> 133337\nsay MBE_factor(\"25246363781991463940137062180162737\");              #=> 6156182033\nsay MBE_factor(\"133337481996728163387583397826265769\");             #=> 401417\nsay MBE_factor(\"950928942549203243363840778331691788194718753\");    #=> 340282366920938463463374607431768211457\n"
  },
  {
    "path": "Math/PSW_primality_test.pl",
    "content": "#!/usr/bin/perl\n\n# The PSW primality test, named after Carl Pomerance, John Selfridge, and Samuel Wagstaff.\n\n# No counter-examples are known to this test.\n\n# Algorithm: given an odd integer n, that is not a perfect power:\n#   1. Perform a (strong) base-2 Fermat test.\n#   2. Find the first P>0 such that kronecker(P^2 + 4, n) = -1.\n#   3. If the Lucas U sequence: U(P, -1, n+1) = 0 (mod n), then n is probably prime.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Lucas_pseudoprime\n#   https://en.wikipedia.org/wiki/Baillie%E2%80%93PSW_primality_test\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse ntheory qw(is_prime is_power lucas_sequence kronecker powmod);\n\nsub findP($n) {\n\n    # Find P such that kronecker(P^2 + 4, n) = -1.\n    for (my $k = 1 ; ; ++$k) {\n        if (kronecker($k*$k + 4, $n) == -1) {\n            return $k;\n        }\n    }\n}\n\nsub PSW_primality_test ($n) {\n\n    return 0 if $n <= 1;\n    return 1 if $n == 2;\n\n    return 0 if !($n & 1);\n    return 0 if is_power($n);\n\n    # Fermat base-2 test\n    powmod(2, $n - 1, $n) == 1 or return 0;\n\n    my $P = findP($n);\n    my $Q = -1;\n\n    # If LucasU(P, -1, n+1) = 0 (mod n), then n is probably prime.\n    (lucas_sequence($n, $P, $Q, $n + 1))[0] == 0;\n}\n\n#\n## Run some tests\n#\n\nmy $from  = 1;\nmy $to    = 1e6;\nmy $count = 0;\n\nforeach my $n ($from .. $to) {\n    if (PSW_primality_test($n)) {\n        if (not is_prime($n)) {\n            say \"Counter-example: $n\";\n        }\n        ++$count;\n    }\n    elsif (is_prime($n)) {\n        say \"Missed a prime: $n\";\n    }\n}\n\nsay \"There are $count primes between $from and $to.\";\n"
  },
  {
    "path": "Math/PSW_primality_test_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# The PSW primality test, named after Carl Pomerance, John Selfridge, and Samuel Wagstaff.\n\n# No counter-examples are known to this test.\n\n# Algorithm: given an odd integer n, that is not a perfect power:\n#   1. Perform a (strong) base-2 Fermat test.\n#   2. Find the first P>0 such that kronecker(P^2 + 4, n) = -1.\n#   3. If the Lucas U sequence: U(P, -1, n+1) = 0 (mod n), then n is probably prime.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Lucas_pseudoprime\n#   https://en.wikipedia.org/wiki/Baillie%E2%80%93PSW_primality_test\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse Math::GMPz;\nuse ntheory qw(is_prime lucas_sequence);\n\nsub PSW_primality_test ($n) {\n\n    $n = Math::GMPz->new(\"$n\");\n\n    return 0 if Math::GMPz::Rmpz_cmp_ui($n, 1) <= 0;\n    return 1 if Math::GMPz::Rmpz_cmp_ui($n, 2) == 0;\n\n    return 0 if Math::GMPz::Rmpz_even_p($n);\n    return 0 if Math::GMPz::Rmpz_perfect_power_p($n);\n\n    my $d = Math::GMPz::Rmpz_init();\n    my $t = Math::GMPz::Rmpz_init_set_ui(2);\n\n    # Fermat base-2 test\n    Math::GMPz::Rmpz_sub_ui($d, $n, 1);\n    Math::GMPz::Rmpz_powm($t, $t, $d, $n);\n    Math::GMPz::Rmpz_cmp_ui($t, 1) and return 0;\n\n    # Find P such that kronecker(P^2 - 4*Q, n) = -1.\n    my $P;\n    for (my $k = 1 ; ; ++$k) {\n        if (Math::GMPz::Rmpz_ui_kronecker($k * $k + 4, $n) == -1) {\n            $P = $k;\n            last;\n        }\n    }\n\n    # If LucasU(P, -1, n+1) = 0 (mod n), then n is probably prime.\n    (lucas_sequence($n, $P, -1, $n + 1))[0] == 0;\n}\n\n#\n## Run some tests\n#\n\nmy $from  = 1;\nmy $to    = 1e5;\nmy $count = 0;\n\nforeach my $n ($from .. $to) {\n    if (PSW_primality_test($n)) {\n        if (not is_prime($n)) {\n            say \"Counter-example: $n\";\n        }\n        ++$count;\n    }\n    elsif (is_prime($n)) {\n        say \"Missed a prime: $n\";\n    }\n}\n\nsay \"There are $count primes between $from and $to.\";\n"
  },
  {
    "path": "Math/RSA_PRNG.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 19 January 2017\n# https://github.com/trizen\n\n# A concept for a new pseudorandom number generator,\n# based on the idea of the RSA encryption algorithm.\n\n# Under development and analysis...\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(gcd irand powmod);\nuse ntheory qw(random_strong_prime);\n\n{\n    my $p = Math::AnyNum->new(random_strong_prime(256));\n    my $q = Math::AnyNum->new(random_strong_prime(256));\n\n    my $n = $p * $q;\n    my $phi = ($p - 1) * ($q - 1);\n\n    my $e;\n#<<<\n    do {\n        $e = irand(65537, $n);\n    } until (\n            $e < $phi\n        and gcd($e,     $phi  ) == 1\n        and gcd($e - 1, $p - 1) == 2\n        and gcd($e - 1, $q - 1) == 2\n    );\n#>>>\n\n    sub RSA_PRNG {\n        my ($seed) = @_;\n\n        my $state = abs($seed);\n\n        sub {\n            $state = powmod($state + 11, $e, $n) & 0x7fff_ffff;\n        };\n    }\n}\n\nmy $rand = RSA_PRNG(42);\n\nforeach my $i (1 .. 20) {\n    say $rand->();\n}\n"
  },
  {
    "path": "Math/RSA_example.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 10 January 2017\n# https://github.com/trizen\n\n# A simple example for the RSA algorithm.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(random_strong_prime);\n\nmy $p = random_strong_prime(2048);\nmy $q = random_strong_prime(2048);\n\nmy $n = ($p * $q);\n\nmy $phi = ($p - 1) * ($q - 1);\n\nsub gcd($$) {\n    my ($u, $v) = @_;\n    while ($v) {\n        ($u, $v) = ($v, $u % $v);\n    }\n    return abs($u);\n}\n\nmy $e = 0;\nfor (my $k = 16 ; gcd($e, $phi) != 1 ; ++$k) {\n    $e = 2**$k + 1;\n}\n\nsub invmod($$) {\n    my ($a, $n) = @_;\n    my ($t, $nt, $r, $nr) = (0, 1, $n, $a % $n);\n    while ($nr != 0) {\n        my $quot = int(($r - ($r % $nr)) / $nr);\n        ($nt, $t) = ($t - $quot * $nt, $nt);\n        ($nr, $r) = ($r - $quot * $nr, $nr);\n    }\n    return if $r > 1;\n    $t += $n if $t < 0;\n    return $t;\n}\n\nmy $d = invmod($e, $phi);\n\nsub expmod($$$) {\n    my ($a, $b, $n) = @_;\n    my $c = 1;\n    do {\n        ($c *= $a) %= $n if $b & 1;\n        ($a *= $a) %= $n;\n    } while ($b >>= 1);\n    return $c;\n}\n\nmy $m = 1234;\nmy $c = expmod($m, $e, $n);\nmy $M = expmod($c, $d, $n);\nsay $M;\n"
  },
  {
    "path": "Math/additive_binomial.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 15 October 2017\n# https://github.com/trizen\n\n# Analogy to the binomial coefficient, using addition instead of multiplication.\n\n# Defined as:\n#    additive_binomial(n, k) = (Sum_{a = n-k+1..n} a) - (Sum_{b = 1..k} b)\n#                            = n*(n+1)/2 - (n-k)*(n-k+1)/2 - k*(k+1)/2\n#                            = n*k - k^2\n#                            = k*(n-k)\n\n# Additionally:\n#   f(x, n) = Sum_{k=0, n} ( additive_binomial(n, k) + x*k )\n#           = x*n*(n+1)/2 + (n+1)/3 * n*(n-1)/2\n#           = x*(n^2 + n)/2 + (n^3 - n)/6\n#           = {x, 3x+1, 6x+4, 10x+10, 15x+20, 21x+35, 28x+56, 36x+84, 45x+120, 55x+165, ...}\n\n# Where for x=1, we have:\n#   f(1, n) = {1, 4, 10, 20, 35, 56, 84, 120, 165, 220, 286, 364, 455, 560, 680, 816, 969, ...}\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nsub additive_binomial ($n, $k) {\n    $k * ($n - $k);\n}\n\nforeach my $n (0 .. 19) {\n    say join(' ', map { sprintf('%2s', additive_binomial($n, $_)) } 0 .. $n);\n}\n\n__END__\n 0\n 0  0\n 0  1  0\n 0  2  2  0\n 0  3  4  3  0\n 0  4  6  6  4  0\n 0  5  8  9  8  5  0\n 0  6 10 12 12 10  6  0\n 0  7 12 15 16 15 12  7  0\n 0  8 14 18 20 20 18 14  8  0\n 0  9 16 21 24 25 24 21 16  9  0\n 0 10 18 24 28 30 30 28 24 18 10  0\n 0 11 20 27 32 35 36 35 32 27 20 11  0\n 0 12 22 30 36 40 42 42 40 36 30 22 12  0\n 0 13 24 33 40 45 48 49 48 45 40 33 24 13  0\n 0 14 26 36 44 50 54 56 56 54 50 44 36 26 14  0\n 0 15 28 39 48 55 60 63 64 63 60 55 48 39 28 15  0\n 0 16 30 42 52 60 66 70 72 72 70 66 60 52 42 30 16  0\n 0 17 32 45 56 65 72 77 80 81 80 77 72 65 56 45 32 17  0\n 0 18 34 48 60 70 78 84 88 90 90 88 84 78 70 60 48 34 18  0\n"
  },
  {
    "path": "Math/additive_partitions.pl",
    "content": "#!/usr/bin/perl\n\n# Generate all additive partitions of a given number.\n# With support for specifying the largest value in a partition.\n\nuse 5.036;\n\nsub partitions ($n, $max_part = $n) {\n    my @results;\n\n    sub ($n, $max_part, $current) {\n\n        if ($n == 0) {\n            push @results, [@$current];\n            return;\n        }\n\n        my $upper = ($n < $max_part ? $n : $max_part);\n\n        for my $part (1 .. $upper) {\n            push @$current, $part;\n            __SUB__->($n - $part, $part, $current);\n            pop @$current;    # backtrack\n        }\n    }->($n, $max_part, []);\n\n    return @results;\n}\n\nmy $n          = shift(@ARGV) // 5;\nmy $max_part   = shift(@ARGV) // $n;\nmy @partitions = partitions($n, $max_part);\nmy $count      = scalar @partitions;\n\nprintf \"Additive partitions of %d  (%d total):\\n\", $n, $count;\nprintf \"  [%s]\\n\", join(', ', @$_) for @partitions;\n\n__END__\nAdditive partitions of 5  (7 total):\n  [1, 1, 1, 1, 1]\n  [2, 1, 1, 1]\n  [2, 2, 1]\n  [3, 1, 1]\n  [3, 2]\n  [4, 1]\n  [5]\n"
  },
  {
    "path": "Math/alexandrian_integers.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 18 August 2016\n# License: GPLv3\n# Website: https://github.com/trizen\n\n# Get the nth Alexandrian integer.\n\n# See also: https://oeis.org/A147811\n#           https://projecteuler.net/problem=221\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(divisors);\n\nsub nth_alexandrian {\n    my ($nth) = @_;\n\n    return 120 if $nth == 3;    # hmm...\n\n    my %nums;\n    my $count = 0;\n    my $prev  = 6;\n\n  OUT: foreach my $n (1 .. $nth) {\n        foreach my $d (divisors($n * $n + 1)) {\n\n            my $q = $n + $d;\n            my $r = ($n + ($n * $n + 1) / $d);\n\n            last if $q > $r;\n\n            my $A = $n * $q * $r;\n            --$count if ($A < $prev);\n\n            if (not exists $nums{$A}) {\n                undef $nums{$A};\n                $prev = $A;\n                last OUT if (++$count == $nth);\n            }\n        }\n    }\n\n    +(sort { $a <=> $b } keys %nums)[$nth - 1];\n}\n\nforeach my $n (1 .. 20) {\n    say \"A($n) = \", nth_alexandrian($n);\n}\n\n__END__\nA(1) = 6\nA(2) = 42\nA(3) = 120\nA(4) = 156\nA(5) = 420\nA(6) = 630\nA(7) = 930\nA(8) = 1428\nA(9) = 1806\nA(10) = 2016\nA(11) = 2184\nA(12) = 3192\nA(13) = 4950\nA(14) = 5256\nA(15) = 8190\nA(16) = 8364\nA(17) = 8970\nA(18) = 10296\nA(19) = 10998\nA(20) = 12210\n"
  },
  {
    "path": "Math/almost_prime_divisors.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 02 August 2020\n# https://github.com/trizen\n\n# Generate all the k-almost prime divisors of n.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub almost_prime_divisors ($n, $k) {\n\n    my @pp = factor_exp($n);\n    my @d  = ([1, 0]);\n\n    foreach my $pp (@pp) {\n\n        my $p = $pp->[0];\n        my $e = $pp->[1];\n\n        my @t;\n        my $r = [1, 0];\n\n        for my $i (1 .. $e) {\n\n            $r->[0] = mulint($r->[0], $p);\n            $r->[1]++;\n\n            if ($r->[1] == $k) {\n                push @t, [$r->[0], $r->[1]];\n                last;\n            }\n\n            foreach my $u (@d) {\n                if ($u->[1] + $r->[1] <= $k) {\n                    push @t, [mulint($u->[0], $r->[0]), $u->[1] + $r->[1]];\n                }\n            }\n        }\n\n        push @d, @t;\n    }\n\n    sort { $a <=> $b } map { $_->[0] } grep { $_->[1] == $k } @d;\n}\n\nmy $n = factorial(10);\n\nforeach my $k (0 .. factor($n)) {\n    my @divisors = almost_prime_divisors($n, $k);\n    printf(\"%2d-almost prime divisors of %s: [%s]\\n\", $k, $n, join(', ', @divisors));\n}\n\n__END__\n 0-almost prime divisors of 3628800: [1]\n 1-almost prime divisors of 3628800: [2, 3, 5, 7]\n 2-almost prime divisors of 3628800: [4, 6, 9, 10, 14, 15, 21, 25, 35]\n 3-almost prime divisors of 3628800: [8, 12, 18, 20, 27, 28, 30, 42, 45, 50, 63, 70, 75, 105, 175]\n 4-almost prime divisors of 3628800: [16, 24, 36, 40, 54, 56, 60, 81, 84, 90, 100, 126, 135, 140, 150, 189, 210, 225, 315, 350, 525]\n 5-almost prime divisors of 3628800: [32, 48, 72, 80, 108, 112, 120, 162, 168, 180, 200, 252, 270, 280, 300, 378, 405, 420, 450, 567, 630, 675, 700, 945, 1050, 1575]\n 6-almost prime divisors of 3628800: [64, 96, 144, 160, 216, 224, 240, 324, 336, 360, 400, 504, 540, 560, 600, 756, 810, 840, 900, 1134, 1260, 1350, 1400, 1890, 2025, 2100, 2835, 3150, 4725]\n 7-almost prime divisors of 3628800: [128, 192, 288, 320, 432, 448, 480, 648, 672, 720, 800, 1008, 1080, 1120, 1200, 1512, 1620, 1680, 1800, 2268, 2520, 2700, 2800, 3780, 4050, 4200, 5670, 6300, 9450, 14175]\n 8-almost prime divisors of 3628800: [256, 384, 576, 640, 864, 896, 960, 1296, 1344, 1440, 1600, 2016, 2160, 2240, 2400, 3024, 3240, 3360, 3600, 4536, 5040, 5400, 5600, 7560, 8100, 8400, 11340, 12600, 18900, 28350]\n 9-almost prime divisors of 3628800: [768, 1152, 1280, 1728, 1792, 1920, 2592, 2688, 2880, 3200, 4032, 4320, 4480, 4800, 6048, 6480, 6720, 7200, 9072, 10080, 10800, 11200, 15120, 16200, 16800, 22680, 25200, 37800, 56700]\n10-almost prime divisors of 3628800: [2304, 3456, 3840, 5184, 5376, 5760, 6400, 8064, 8640, 8960, 9600, 12096, 12960, 13440, 14400, 18144, 20160, 21600, 22400, 30240, 32400, 33600, 45360, 50400, 75600, 113400]\n11-almost prime divisors of 3628800: [6912, 10368, 11520, 16128, 17280, 19200, 24192, 25920, 26880, 28800, 36288, 40320, 43200, 44800, 60480, 64800, 67200, 90720, 100800, 151200, 226800]\n12-almost prime divisors of 3628800: [20736, 34560, 48384, 51840, 57600, 72576, 80640, 86400, 120960, 129600, 134400, 181440, 201600, 302400, 453600]\n13-almost prime divisors of 3628800: [103680, 145152, 172800, 241920, 259200, 362880, 403200, 604800, 907200]\n14-almost prime divisors of 3628800: [518400, 725760, 1209600, 1814400]\n15-almost prime divisors of 3628800: [3628800]\n"
  },
  {
    "path": "Math/almost_prime_divisors_recursive.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 10 March 2021\n# https://github.com/trizen\n\n# Generate all the k-almost prime divisors of n.\n\nuse 5.020;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub almost_prime_divisors ($n, $k) {\n\n    if ($k == 0) {\n        return (1);\n    }\n\n    my @factor_exp  = factor_exp($n);\n    my @factors     = map { $_->[0] } @factor_exp;\n    my %valuations  = map { @$_ } @factor_exp;\n    my $factors_end = $#factors;\n\n    if ($k == 1) {\n        return @factors;\n    }\n\n    my @list;\n\n    sub ($m, $k, $i = 0) {\n\n        if ($k == 1) {\n\n            my $L = divint($n, $m);\n\n            foreach my $j ($i .. $factors_end) {\n\n                my $q = $factors[$j];\n                $q > $L and last;\n\n                if (valuation($m, $q) < $valuations{$q}) {\n                    push(@list, mulint($m, $q));\n                }\n            }\n\n            return;\n        }\n\n        my $L = rootint(divint($n, $m), $k);\n\n        foreach my $j ($i .. $factors_end) {\n\n            my $q = $factors[$j];\n            $q > $L and last;\n\n            if (valuation($m, $q) < $valuations{$q}) {\n                __SUB__->(mulint($m, $q), $k - 1, $j);\n            }\n        }\n    }->(1, $k);\n\n    sort { $a <=> $b } @list;\n}\n\nmy $n = factorial(10);\n\nforeach my $k (0 .. factor($n)) {\n    my @divisors = almost_prime_divisors($n, $k);\n    printf(\"%2d-almost prime divisors of %s: [%s]\\n\", $k, $n, join(', ', @divisors));\n}\n\n__END__\n 0-almost prime divisors of 3628800: [1]\n 1-almost prime divisors of 3628800: [2, 3, 5, 7]\n 2-almost prime divisors of 3628800: [4, 6, 9, 10, 14, 15, 21, 25, 35]\n 3-almost prime divisors of 3628800: [8, 12, 18, 20, 27, 28, 30, 42, 45, 50, 63, 70, 75, 105, 175]\n 4-almost prime divisors of 3628800: [16, 24, 36, 40, 54, 56, 60, 81, 84, 90, 100, 126, 135, 140, 150, 189, 210, 225, 315, 350, 525]\n 5-almost prime divisors of 3628800: [32, 48, 72, 80, 108, 112, 120, 162, 168, 180, 200, 252, 270, 280, 300, 378, 405, 420, 450, 567, 630, 675, 700, 945, 1050, 1575]\n 6-almost prime divisors of 3628800: [64, 96, 144, 160, 216, 224, 240, 324, 336, 360, 400, 504, 540, 560, 600, 756, 810, 840, 900, 1134, 1260, 1350, 1400, 1890, 2025, 2100, 2835, 3150, 4725]\n 7-almost prime divisors of 3628800: [128, 192, 288, 320, 432, 448, 480, 648, 672, 720, 800, 1008, 1080, 1120, 1200, 1512, 1620, 1680, 1800, 2268, 2520, 2700, 2800, 3780, 4050, 4200, 5670, 6300, 9450, 14175]\n 8-almost prime divisors of 3628800: [256, 384, 576, 640, 864, 896, 960, 1296, 1344, 1440, 1600, 2016, 2160, 2240, 2400, 3024, 3240, 3360, 3600, 4536, 5040, 5400, 5600, 7560, 8100, 8400, 11340, 12600, 18900, 28350]\n 9-almost prime divisors of 3628800: [768, 1152, 1280, 1728, 1792, 1920, 2592, 2688, 2880, 3200, 4032, 4320, 4480, 4800, 6048, 6480, 6720, 7200, 9072, 10080, 10800, 11200, 15120, 16200, 16800, 22680, 25200, 37800, 56700]\n10-almost prime divisors of 3628800: [2304, 3456, 3840, 5184, 5376, 5760, 6400, 8064, 8640, 8960, 9600, 12096, 12960, 13440, 14400, 18144, 20160, 21600, 22400, 30240, 32400, 33600, 45360, 50400, 75600, 113400]\n11-almost prime divisors of 3628800: [6912, 10368, 11520, 16128, 17280, 19200, 24192, 25920, 26880, 28800, 36288, 40320, 43200, 44800, 60480, 64800, 67200, 90720, 100800, 151200, 226800]\n12-almost prime divisors of 3628800: [20736, 34560, 48384, 51840, 57600, 72576, 80640, 86400, 120960, 129600, 134400, 181440, 201600, 302400, 453600]\n13-almost prime divisors of 3628800: [103680, 145152, 172800, 241920, 259200, 362880, 403200, 604800, 907200]\n14-almost prime divisors of 3628800: [518400, 725760, 1209600, 1814400]\n15-almost prime divisors of 3628800: [3628800]\n"
  },
  {
    "path": "Math/almost_prime_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 14 February 2021\n# https://github.com/trizen\n\n# Generate k-almost prime numbers <= n. (not in sorted order)\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n\nuse 5.020;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub almost_prime_numbers ($n, $k, $callback) {\n\n    sub ($m, $p, $r) {\n\n        if ($r == 1) {\n\n            forprimes {\n                $callback->(mulint($m, $_));\n            } $p, divint($n, $m);\n\n            return;\n        }\n\n        my $s = rootint(divint($n, $m), $r);\n\n        for (my $q = $p ; $q <= $s ; $q = next_prime($q)) {\n            __SUB__->(mulint($m, $q), $q, $r - 1);\n        }\n    }->(1, 2, $k);\n}\n\n# Generate all the numbers k <= 100 for which bigomega(k) = 4\nalmost_prime_numbers(100, 4, sub ($n) { say $n });\n"
  },
  {
    "path": "Math/almost_prime_numbers_in_range.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 15 February 2021\n# https://github.com/trizen\n\n# Generate k-almost prime numbers in range [a,b]. (not in sorted order)\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\n\nsub almost_prime_numbers ($A, $B, $k, $callback) {\n\n    $A = vecmax($A, powint(2, $k));\n\n    sub ($m, $p, $k) {\n\n        if ($k == 1) {\n\n            forprimes {\n                $callback->(mulint($m, $_));\n            } vecmax($p, cdivint($A, $m)), divint($B, $m);\n\n            return;\n        }\n\n        my $s = rootint(divint($B, $m), $k);\n\n        while ($p <= $s) {\n\n            my $t = mulint($m, $p);\n\n            if (cdivint($A, $t) <= divint($B, $t)) {\n                __SUB__->($t, $p, $k - 1);\n            }\n\n            $p = next_prime($p);\n        }\n    }->(1, 2, $k);\n}\n\n# Generate 5-almost primes in the range [50, 1000]\n\nmy $k    = 5;\nmy $from = 50;\nmy $upto = 1000;\n\nmy @arr; almost_prime_numbers($from, $upto, $k, sub ($n) { push @arr, $n });\n\nmy @test = grep { is_almost_prime($k, $_) } $from..$upto;   # just for testing\njoin(' ', sort { $a <=> $b } @arr) eq join(' ', @test) or die \"Error: not equal!\";\n\nsay join(', ', @arr);\n"
  },
  {
    "path": "Math/almost_prime_numbers_in_range_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 15 February 2021\n# Edit: 04 April 2024\n# https://github.com/trizen\n\n# Generate all the k-almost prime numbers in range [A,B].\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n\nuse 5.036;\nuse ntheory qw(:all);\nuse Math::GMPz;\n\nsub almost_prime_numbers ($A, $B, $k) {\n\n    my $u = Math::GMPz::Rmpz_init();\n    my $v = Math::GMPz::Rmpz_init();\n\n    Math::GMPz::Rmpz_setbit($u, $k);\n\n    $A = vecmax($A, $u);\n    $A = Math::GMPz->new(\"$A\");\n    $B = Math::GMPz->new(\"$B\");\n\n    my @values = sub ($m, $lo, $k) {\n\n        Math::GMPz::Rmpz_tdiv_q($u, $B, $m);\n        Math::GMPz::Rmpz_root($u, $u, $k);\n\n        my $hi = Math::GMPz::Rmpz_get_ui($u);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        my @lst;\n\n        if ($k == 1) {\n\n            Math::GMPz::Rmpz_cdiv_q($u, $A, $m);\n\n            if (Math::GMPz::Rmpz_fits_ulong_p($u)) {\n                $lo = vecmax($lo, Math::GMPz::Rmpz_get_ui($u));\n            }\n            elsif (Math::GMPz::Rmpz_cmp_ui($u, $lo) > 0) {\n                if (Math::GMPz::Rmpz_cmp_ui($u, $hi) > 0) {\n                    return;\n                }\n                $lo = Math::GMPz::Rmpz_get_ui($u);\n            }\n\n            if ($lo > $hi) {\n                return;\n            }\n\n            foreach my $p (@{primes($lo, $hi)}) {\n                my $v = Math::GMPz::Rmpz_init();\n                Math::GMPz::Rmpz_mul_ui($v, $m, $p);\n                push @lst, $v;\n            }\n\n            return @lst;\n        }\n\n        my $z = Math::GMPz::Rmpz_init();\n\n        foreach my $p (@{primes($lo, $hi)}) {\n            Math::GMPz::Rmpz_mul_ui($z, $m, $p);\n\n            Math::GMPz::Rmpz_cdiv_q($u, $A, $z);\n            Math::GMPz::Rmpz_tdiv_q($v, $B, $z);\n\n            if (Math::GMPz::Rmpz_cmp($u, $v) <= 0) {\n                push @lst, __SUB__->($z, $p, $k - 1);\n            }\n        }\n\n        return @lst;\n      }\n      ->(Math::GMPz->new(1), 2, $k);\n\n    sort { Math::GMPz::Rmpz_cmp($a, $b) } @values;\n}\n\n# Generate 5-almost primes in the range [50, 1000]\n\nmy $k    = 5;\nmy $from = 50;\nmy $upto = 1000;\n\nmy @arr  = almost_prime_numbers($from, $upto, $k);\nmy @test = grep { is_almost_prime($k, $_) } $from .. $upto;    # just for testing\n\njoin(' ', @arr) eq join(' ', @test) or die \"Error: not equal!\";\n\nsay join(', ', @arr);\n"
  },
  {
    "path": "Math/almost_prime_numbers_in_range_v2.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 15 February 2021\n# Edit: 06 August 2024\n# https://github.com/trizen\n\n# Generate k-almost prime numbers in range [a,b]. (not in sorted order)\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n\nuse 5.036;\nuse ntheory qw(:all);\n\nsub almost_prime_numbers ($A, $B, $k, $callback) {\n\n    $A = vecmax($A, powint(2, $k));\n\n    sub ($m, $lo, $k) {\n\n        if ($k == 1) {\n\n            forprimes {\n                $callback->($m * $_);\n            } vecmax($lo, cdivint($A, $m)), divint($B, $m);\n\n            return;\n        }\n\n        my $hi = rootint(divint($B, $m), $k);\n\n        foreach my $p (@{primes($lo, $hi)}) {\n            __SUB__->($m * $p, $p, $k - 1);\n        }\n      }\n      ->(1, 2, $k);\n}\n\n# Generate 5-almost primes in the range [50, 1000]\n\nmy $k    = 5;\nmy $from = 50;\nmy $upto = 1000;\n\nmy @arr;\nalmost_prime_numbers($from, $upto, $k, sub ($n) { push @arr, $n });\n\nmy @test = grep { is_almost_prime($k, $_) } $from .. $upto;    # just for testing\njoin(' ', sort { $a <=> $b } @arr) eq join(' ', @test) or die \"Error: not equal!\";\n\nsay join(', ', @arr);\n"
  },
  {
    "path": "Math/almost_primes_from_factor_list.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 29 March 2021\n# https://github.com/trizen\n\n# Generate all the possible k-almost primes <= n, using a given list of prime factors.\n\nuse 5.020;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub almost_primes ($n, $k, $factors, $squarefree = 0) {\n\n    my $factors_end = $#{$factors};\n\n    if ($k == 0) {\n        return (1);\n    }\n\n    if ($k == 1) {\n        return @$factors;\n    }\n\n    my @list;\n\n    sub ($m, $k, $i = 0) {\n\n        if ($k == 1) {\n\n            my $L = divint($n, $m);\n\n            foreach my $j ($i .. $factors_end) {\n                my $q = $factors->[$j];\n                last if ($q > $L);\n                push(@list, mulint($m, $q));\n            }\n\n            return;\n        }\n\n        my $L = rootint(divint($n, $m), $k);\n\n        foreach my $j ($i .. $factors_end) {\n            my $q = $factors->[$j];\n            last if ($q > $L);\n            __SUB__->(mulint($m, $q), $k - 1, $j + $squarefree);\n        }\n    }->(1, $k);\n\n    sort { $a <=> $b } @list;\n}\n\nmy $n       = 1e3;              # limit\nmy @factors = @{primes(11)};    # prime list\n\nforeach my $k (0 .. scalar(@factors)) {\n    my @divisors = almost_primes($n, $k, \\@factors);\n    printf(\"%2d-almost primes <= %s: [%s]\\n\", $k, $n, join(', ', @divisors));\n}\n\n__END__\n 0-almost primes <= 1000: [1]\n 1-almost primes <= 1000: [2, 3, 5, 7, 11]\n 2-almost primes <= 1000: [4, 6, 9, 10, 14, 15, 21, 22, 25, 33, 35, 49, 55, 77, 121]\n 3-almost primes <= 1000: [8, 12, 18, 20, 27, 28, 30, 42, 44, 45, 50, 63, 66, 70, 75, 98, 99, 105, 110, 125, 147, 154, 165, 175, 231, 242, 245, 275, 343, 363, 385, 539, 605, 847]\n 4-almost primes <= 1000: [16, 24, 36, 40, 54, 56, 60, 81, 84, 88, 90, 100, 126, 132, 135, 140, 150, 189, 196, 198, 210, 220, 225, 250, 294, 297, 308, 315, 330, 350, 375, 441, 462, 484, 490, 495, 525, 550, 625, 686, 693, 726, 735, 770, 825, 875]\n 5-almost primes <= 1000: [32, 48, 72, 80, 108, 112, 120, 162, 168, 176, 180, 200, 243, 252, 264, 270, 280, 300, 378, 392, 396, 405, 420, 440, 450, 500, 567, 588, 594, 616, 630, 660, 675, 700, 750, 882, 891, 924, 945, 968, 980, 990]\n"
  },
  {
    "path": "Math/almost_primes_in_range_from_factor_list.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 17 March 2023\n# https://github.com/trizen\n\n# Generate all the possible k-almost primes in a given range [A, B], using a given list of prime factors.\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\n\nsub almost_primes_in_range ($A, $B, $k, $factors, $squarefree = 0) {\n\n    $A = vecmax($A, ($squarefree ? pn_primorial($k) : powint(2, $k)));\n\n    my $factors_end = $#{$factors};\n\n    if ($k == 0) {\n        return (($A > 1) ? () : 1);\n    }\n\n    my @list;\n\n    sub ($m, $k, $i = 0) {\n\n        my $lo = $factors->[$i];\n        my $hi = rootint(divint($B, $m), $k);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        if ($k == 1) {\n\n            $lo = vecmax($lo, cdivint($A, $m));\n\n            if ($lo > $hi) {\n                return;\n            }\n\n            foreach my $j ($i .. $factors_end) {\n                my $q = $factors->[$j];\n                last if ($q > $hi);\n                next if ($q < $lo);\n                push(@list, mulint($m, $q));\n            }\n\n            return;\n        }\n\n        foreach my $j ($i .. ($factors_end - $squarefree)) {\n            my $q = $factors->[$j];\n            last if ($q > $hi);\n            next if ($q < $lo);\n            __SUB__->(mulint($m, $q), $k - 1, $j + $squarefree);\n        }\n      }\n      ->(1, $k);\n\n    sort { $a <=> $b } @list;\n}\n\nmy $from    = 1;\nmy $upto    = 1e3;\nmy @factors = @{primes(11)};    # prime list\n\nforeach my $k (0 .. scalar(@factors)) {\n    my @divisors = almost_primes_in_range($from, $upto, $k, \\@factors);\n    printf(\"%2d-almost primes in range [%s, %s]: [%s]\\n\", $k, $from, $upto, join(', ', @divisors));\n}\n\n__END__\n 0-almost primes in range [1, 1000]: [1]\n 1-almost primes in range [1, 1000]: [2, 3, 5, 7, 11]\n 2-almost primes in range [1, 1000]: [4, 6, 9, 10, 14, 15, 21, 22, 25, 33, 35, 49, 55, 77, 121]\n 3-almost primes in range [1, 1000]: [8, 12, 18, 20, 27, 28, 30, 42, 44, 45, 50, 63, 66, 70, 75, 98, 99, 105, 110, 125, 147, 154, 165, 175, 231, 242, 245, 275, 343, 363, 385, 539, 605, 847]\n 4-almost primes in range [1, 1000]: [16, 24, 36, 40, 54, 56, 60, 81, 84, 88, 90, 100, 126, 132, 135, 140, 150, 189, 196, 198, 210, 220, 225, 250, 294, 297, 308, 315, 330, 350, 375, 441, 462, 484, 490, 495, 525, 550, 625, 686, 693, 726, 735, 770, 825, 875]\n 5-almost primes in range [1, 1000]: [32, 48, 72, 80, 108, 112, 120, 162, 168, 176, 180, 200, 243, 252, 264, 270, 280, 300, 378, 392, 396, 405, 420, 440, 450, 500, 567, 588, 594, 616, 630, 660, 675, 700, 750, 882, 891, 924, 945, 968, 980, 990]\n"
  },
  {
    "path": "Math/area_of_triangle.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 17 August 2016\n# Website: https://github.com/trizen\n\n# Find the area of a triangle where all three sides are known, using Heron's Formula.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub triangle_area {\n    my ($x, $y, $z) = @_;\n    my $s = ($x + $y + $z) / 2;\n    sqrt($s * ($s - $x) * ($s - $y) * ($s - $z));\n}\n\nsay triangle_area(5, 5, 6);\n"
  },
  {
    "path": "Math/arithmetic_derivative.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 18 August 2017\n# https://github.com/trizen\n\n# A simple implementation of the arithmetic derivative function for positive integers.\n\n# See also:\n#   https://projecteuler.net/problem=484\n\nuse 5.016;\nuse strict;\nuse warnings;\n\nuse ntheory qw(factor);\n\nsub arithmetic_derivative {\n    my ($n) = @_;\n\n    my $sum = 0;\n    foreach my $p (factor($n)) {\n        $sum += $n / $p;\n    }\n\n    return $sum;\n}\n\nsay arithmetic_derivative(1234);            #=> 619\nsay arithmetic_derivative(479001600);       #=> 3496919040\nsay arithmetic_derivative(162375475128);    #=> 298100392484\n"
  },
  {
    "path": "Math/arithmetic_expressions.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 07 August 2016\n# Website: https://github.com/trizen\n\n# Generate arithmetic expressions, using a set of 4 integers and 4 operators.\n# Problem from: https://projecteuler.net/problem=93\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(forperm);\n\nmy @op = ('+', '-', '*', '/');\n\nmy @expr = (\n            \"%d %s %d %s %d %s %d\",\n            \"%d %s (%d %s (%d %s %d))\",\n            \"%d %s ((%d %s %d) %s %d)\",\n            \"(%d %s (%d %s %d)) %s %d\",\n            \"%d %s (%d %s %d %s %d)\",\n            \"%d %s (%d %s %d) %s %d\",\n            \"%d %s %d %s (%d %s %d)\",\n            \"((%d %s %d) %s %d) %s %d\",\n            \"(%d %s %d) %s (%d %s %d)\",\n           );\n\nsub evaluate {\n    my ($nums, $ops, $table) = @_;\n    foreach my $expr (@expr) {\n\n        my $e = sprintf($expr,\n            $nums->[0], $ops->[0],\n            $nums->[1], $ops->[1],\n            $nums->[2], $ops->[2],\n            $nums->[3]\n        );\n\n        my $n = eval $e;\n\n        if (not $@\n            and $n > 0\n            and int($n) eq $n) {\n            push @{$table->{$n}}, $e;\n        }\n    }\n}\n\nsub compute {\n    my ($set, $table) = @_;\n\n    forperm {\n        my @nums = @{$set}[@_];\n\n        foreach my $i (0 .. 3) {\n            foreach my $j (0 .. 3) {\n                foreach my $k (0 .. 3) {\n                    my @ops = @op[$i, $j, $k];\n                    evaluate(\\@nums, \\@ops, $table);\n                }\n            }\n        }\n\n    }\n    scalar(@$set);\n}\n\nmy @set = (1, 2, 3, 4);\nmy $num = 28;\n\ncompute(\\@set, \\my %table);\n\nif (exists $table{$num}) {\n    say \"\\n=> Using the set [@set], the number $num can be represented as:\\n\";\n    say join(\"\\n\", @{$table{$num}});\n}\nelse {\n    say \"[!] The number $num cannot be represented as an arithmetic expression, using the set [@set].\";\n}\n\n__END__\n\nUsing the set [1 2 3 4], the number 28 can be represented as:\n\n(1 + (2 * 3)) * 4\n(1 + (3 * 2)) * 4\n((2 * 3) + 1) * 4\n((3 * 2) + 1) * 4\n4 * (1 + (2 * 3))\n4 * (1 + 2 * 3)\n4 * (1 + (3 * 2))\n4 * (1 + 3 * 2)\n4 * ((2 * 3) + 1)\n4 * (2 * 3 + 1)\n4 * ((3 * 2) + 1)\n4 * (3 * 2 + 1)\n"
  },
  {
    "path": "Math/arithmetic_geometric_mean_complex.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 17 April 2017\n# https://github.com/trizen\n\n# Implementation of the arithmetic-geometric mean function, in complex numbers.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Arithmetic%E2%80%93geometric_mean\n#   https://www.mathworks.com/help/symbolic/mupad_ref/numeric-gaussagm.html\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::MPC;\n\nour $PREC  = 192;\nour $ROUND = Math::MPC::MPC_RNDNN;\n\n# agm(a, -a) = 0\n# agm(0,  x) = 0\n# agm(x,  0) = 0\n\nsub agm($$) {\n    my ($x, $y) = @_;\n\n    my $a0 = Math::MPC::Rmpc_init2($PREC);\n    my $g0 = Math::MPC::Rmpc_init2($PREC);\n\n    Math::MPC::Rmpc_set_str($a0, $x, 10, $ROUND);\n    Math::MPC::Rmpc_set_str($g0, $y, 10, $ROUND);\n\n    my $a1 = Math::MPC::Rmpc_init2($PREC);\n    my $g1 = Math::MPC::Rmpc_init2($PREC);\n    my $t  = Math::MPC::Rmpc_init2($PREC);\n\n    # agm(0,  x) = 0\n    if (!Math::MPC::Rmpc_cmp_si_si($a0, 0, 0)) {\n        return $a0;\n    }\n\n    # agm(x, 0) = 0\n    if (!Math::MPC::Rmpc_cmp_si_si($g0, 0, 0)) {\n        return $g0;\n    }\n\n    my $count = 0;\n    {\n        Math::MPC::Rmpc_add($a1, $a0, $g0, $ROUND);\n        Math::MPC::Rmpc_div_2exp($a1, $a1, 1, $ROUND);\n\n        Math::MPC::Rmpc_mul($g1, $a0, $g0, $ROUND);\n        Math::MPC::Rmpc_add($t, $a0, $g0, $ROUND);\n        Math::MPC::Rmpc_sqr($t, $t, $ROUND);\n        Math::MPC::Rmpc_cmp_si_si($t, 0, 0) || return $t;\n        Math::MPC::Rmpc_div($g1, $g1, $t, $ROUND);\n        Math::MPC::Rmpc_sqrt($g1, $g1, $ROUND);\n        Math::MPC::Rmpc_add($t, $a0, $g0, $ROUND);\n        Math::MPC::Rmpc_mul($g1, $g1, $t, $ROUND);\n\n        if (Math::MPC::Rmpc_cmp($a0, $a1) and ++$count < $PREC) {\n            Math::MPC::Rmpc_set($a0, $a1, $ROUND);\n            Math::MPC::Rmpc_set($g0, $g1, $ROUND);\n            redo;\n        }\n    }\n\n    return $g0;\n}\n\nsay agm(3,   4);\nsay agm(-1,  2);\nsay agm(1,   -2);\nsay agm(0,   5);\nsay agm(-10, 3.14159265358979323846264338327950288419716939938);\nsay agm(10,  0);\nsay agm(10,  -10);\nsay agm(10,  10);\nsay agm(-3,  -4);\nsay agm(-1,  -1);\nsay agm(-1,  -2);\nsay agm(-2,  -2);\nsay agm(2,   -3);\n"
  },
  {
    "path": "Math/arithmetic_sum_closed_form.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 20 November 2017\n# https://github.com/trizen\n\n# Compute the sum of an arithmetic sequence.\n\n# Example: arithmetic_sum_*(1,3,1) returns 6  because 1+2+3   =  6\n#          arithmetic_sum_*(1,7,2) returns 16 because 1+3+5+7 = 16\n\n# arithmetic_sum_*(begin, end, step)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nsub arithmetic_sum_continuous ($x, $y, $z) {\n    ($x + $y) * (($y - $x) / $z + 1) / 2;\n}\n\nsub arithmetic_sum_discrete ($x, $y, $z) {\n    (int(($y - $x) / $z) + 1) * ($z * int(($y - $x) / $z) + 2 * $x) / 2;\n}\n\nsay arithmetic_sum_continuous(10, 113, 6);    #=> 1117.25\nsay arithmetic_sum_discrete(10, 113, 6);      #=> 1098\n"
  },
  {
    "path": "Math/ascii_cuboid.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 05 June 2012\n# License: GPLv3\n# https://github.com/trizen\n\nuse 5.010;\n\n# usage: script X Y Z [S]\n\nsub cuboid {\n\n    # Constant dimensions of the cuboid\n    my ($x, $y, $z) = map { int } @_[0 .. 2];\n\n    # ASCII characters\n    # $c = corner point\n    # $h = horizontal line\n    # $v = vertical line\n    # $d = diagonal line\n    # $s = space (inside the cuboid)\n    my ($c, $h, $v, $d, $s) = ('+', '-', '|', '/', shift(@ARGV) // q{ });\n\n    say q{ } x ($z + 1), $c, $h x $x, $c;\n    say q{ } x ($z - $_ + 1), $d, $s x $x, $d, $s x ($_ - ($_ > $y ? ($_ - $y) : 1)),\n      $_ - 1 == $y ? $c : $_ > $y ? $d : $v for 1 .. $z;\n    say $c, $h x $x, $c, ($s x ($z < $y ? $z : $y), $z < $y ? $v : $z == $y ? $c : $d);\n    say $v, $s x $x, $v, $z > $y ? $_ >= $z ? ($s x $x, $c) : ($s x ($y - $_), $d)\n      : $y - $_ > $z ? ($s x $z, $v) : ($s x ($y - $_), $y - $_ == $z ? $c : $d) for 1 .. $y;\n    say $c, $h x $x, $c;\n}\n\ncuboid(shift() // rand(20), shift() // rand(10), shift() // rand(10));\n"
  },
  {
    "path": "Math/ascii_julia_set.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 03 January 2018\n# https://github.com/trizen\n\n# ASCII generation of a Julia set (+ANSI colors).\n\n# See also:\n#   https://en.wikipedia.org/wiki/Julia_set\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse Math::GComplex;\nuse Term::ANSIColor qw(:constants);\n\nmy @colors = (\n                (BLACK), (RED),   (GREEN),        (YELLOW),     (BLUE),         (MAGENTA),\n                (CYAN),  (WHITE), (BRIGHT_BLACK), (BRIGHT_RED), (BRIGHT_GREEN), (BRIGHT_YELLOW),\n                (BRIGHT_BLUE), (BRIGHT_MAGENTA), (BRIGHT_CYAN), (BRIGHT_WHITE),\n             );\n\nmy @chars = (' ', '`', '.', ',', ':', ';', '!', '-', '+', '*', '%', '#');\n\nsub range_map ($value, $in_min, $in_max, $out_min, $out_max) {\n      ($value - $in_min)\n        * ($out_max - $out_min)\n        / ($in_max  - $in_min)\n    + $out_min;\n}\n\nsub julia_set ($z, $I = 12, $L = 2, $C = Math::GComplex->new(-0.835, -0.2321)) {\n\n    my $n = 0;\n\n    while (abs($z) < $L and ++$n <= $I) {\n        $z = $z * $z + $C;\n    }\n\n    return (($I - $n) / $I);\n}\n\nfor (my $y = 1 ; $y >= -1 ; $y -= 0.05) {\n    for (my $x = -2 ; $x <= 2 ; $x += 0.0315) {\n        my $num = julia_set(Math::GComplex->new($x, $y));\n        my $color_index = sprintf('%.0f', range_map($num, 0, 1, 0, $#colors));\n        my $char_index  = sprintf('%.0f', range_map($num, 0, 1, 0, $#chars));\n        print($colors[$color_index] . $chars[$char_index]);\n    }\n    print \"\\n\";\n}\n\nprint(RESET);\n"
  },
  {
    "path": "Math/ascii_mandelbrot_set.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 03 January 2018\n# https://github.com/trizen\n\n# ASCII generation of the Mandelbrot set (+ANSI colors).\n\n# See also:\n#   https://en.wikipedia.org/wiki/Mandelbrot_set\n\nuse 5.020;\nuse strict;\nuse experimental qw(signatures);\n\nuse Math::GComplex;\nuse Term::ANSIColor qw(:constants);\n\nmy @colors = reverse(\n              (BLACK), (RED),   (GREEN),        (YELLOW),     (BLUE),         (MAGENTA),\n              (CYAN),  (WHITE), (BRIGHT_BLACK), (BRIGHT_RED), (BRIGHT_GREEN), (BRIGHT_YELLOW),\n              (BRIGHT_BLUE), (BRIGHT_MAGENTA), (BRIGHT_CYAN), (BRIGHT_WHITE),\n             );\n\nmy @chars = ('-', '#', '%', '*', '+', '!', ';', ':', ',', '.');\n\nsub range_map ($value, $in_min, $in_max, $out_min, $out_max) {\n      ($value - $in_min)\n        * ($out_max - $out_min)\n        / ($in_max  - $in_min)\n    + $out_min;\n}\n\nsub mandelbrot_set ($z, $I = 400, $L = 2)  {\n\n    my $n = 0;\n    my $c = $z;\n\n    while (abs($z) < $L and ++$n <= $I) {\n        $z = $z * $z + $c;\n    }\n\n    return (($I - $n) / $I);\n}\n\nfor (my $y = 1 ; $y >= -1 ; $y -= 0.05) {\n    for (my $x = -2 ; $x <= 0.5 ; $x += 0.0315) {\n        my $num = mandelbrot_set(Math::GComplex->new($x, $y));\n        my $color_index = sprintf('%.0f', range_map($num, 0, 1, 0, $#colors));\n        my $char_index  = sprintf('%.0f', range_map($num, 0, 1, 0, $#chars));\n        print($colors[$color_index] . $chars[$char_index]);\n    }\n    print \"\\n\";\n}\n\nprint (RESET);\n"
  },
  {
    "path": "Math/batir_factorial_asymptotic_formula_mpfr.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 21 June 2017\n# https://github.com/trizen\n\n# A very good factorial approximation, due to N. Batir.\n\n# The asymptotic formula is:\n#   n! ~ 1/216 * √(π/70) * exp(-n) * n^(n-2) * √(42*n*(24*n*(90*n*(12*n*(6*n + 1) + 1) - 31) - 139) + 9871)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nour ($ROUND, $PREC);\n\nBEGIN {\n    use Math::MPFR qw();\n    $ROUND = Math::MPFR::MPFR_RNDN();\n    $PREC  = 200;\n}\n\nuse Math::AnyNum (PREC => $PREC);\n\nsub fac_batir {\n    my ($n) = @_;\n\n    my $f = Math::MPFR::Rmpfr_init2($PREC);\n\n    # f = (12*n*(6*n + 1) + 1)\n    Math::MPFR::Rmpfr_set_ui($f, $n, $ROUND);\n    Math::MPFR::Rmpfr_mul_ui($f, $f, 6, $ROUND);\n    Math::MPFR::Rmpfr_add_ui($f, $f, 1, $ROUND);\n    Math::MPFR::Rmpfr_mul_ui($f, $f, $n, $ROUND);\n    Math::MPFR::Rmpfr_mul_ui($f, $f, 12, $ROUND);\n    Math::MPFR::Rmpfr_add_ui($f, $f, 1, $ROUND);\n\n    # f = (24*n*(90*n*f - 31) - 139)\n    Math::MPFR::Rmpfr_mul_ui($f, $f, $n, $ROUND);\n    Math::MPFR::Rmpfr_mul_ui($f, $f, 90, $ROUND);\n    Math::MPFR::Rmpfr_sub_ui($f, $f, 31, $ROUND);\n    Math::MPFR::Rmpfr_mul_ui($f, $f, $n, $ROUND);\n    Math::MPFR::Rmpfr_mul_ui($f, $f, 24, $ROUND);\n    Math::MPFR::Rmpfr_sub_ui($f, $f, 139, $ROUND);\n\n    # f = √(42*n*f + 9871)\n    Math::MPFR::Rmpfr_mul_ui($f, $f, $n, $ROUND);\n    Math::MPFR::Rmpfr_mul_ui($f, $f, 42, $ROUND);\n    Math::MPFR::Rmpfr_add_ui($f, $f, 9871, $ROUND);\n    Math::MPFR::Rmpfr_sqrt($f, $f, $ROUND);\n\n    # f = f * n^(n-2)\n    my $t = Math::MPFR::Rmpfr_init2($PREC);\n    Math::MPFR::Rmpfr_ui_pow_ui($t, $n, $n - 2, $ROUND);\n    Math::MPFR::Rmpfr_mul($f, $f, $t, $ROUND);\n\n    # f = f * exp(-n)\n    Math::MPFR::Rmpfr_set_ui($t, $n, $ROUND);\n    Math::MPFR::Rmpfr_neg($t, $t, $ROUND);\n    Math::MPFR::Rmpfr_exp($t, $t, $ROUND);\n    Math::MPFR::Rmpfr_mul($f, $f, $t, $ROUND);\n\n    # f = f * √(π/70)\n    Math::MPFR::Rmpfr_const_pi($t, $ROUND);\n    Math::MPFR::Rmpfr_div_ui($t, $t, 70, $ROUND);\n    Math::MPFR::Rmpfr_sqrt($t, $t, $ROUND);\n    Math::MPFR::Rmpfr_mul($f, $f, $t, $ROUND);\n\n    # f = f/216\n    Math::MPFR::Rmpfr_div_ui($f, $f, 216, $ROUND);\n\n    # Create and return a new Math::AnyNum object\n    Math::AnyNum->new($f);\n}\n\nforeach my $n (1 .. 10) {\n    say fac_batir($n);\n}\n\n__END__\n1.0001633529366947590265935448207438761433429838411\n2.0000029860747051176081702869925254469658097576474\n6.0000003229774185743648491096337544662543793954941\n24.000000013320139202368363609786566171333392325063\n119.99999982560322070035659496327332403346753218872\n719.99999937604769710505519830495674394359333008983\n5039.9999977053735752532469858794448681595399481797\n40319.999990211060074629645362635300614581980624166\n362879.99995110486335462650403778927886141969579338\n3628799.9997167757110134397984453555772078233918289\n"
  },
  {
    "path": "Math/bell_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Fast algorithm for computing the first n Bell numbers, using Aitken's array.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Bell_number\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n## use Math::AnyNum qw(:overload);\n\nsub bell_numbers ($n) {\n\n    my @acc;\n    my @bell = (1);\n\n    foreach my $k (1 .. $n) {\n\n        my $t = $bell[-1];\n\n        foreach my $i (0 .. $#acc) {\n            $t += $acc[$i];\n            $acc[$i] = $t;\n        }\n\n        unshift(@acc, $bell[-1]);\n        push @bell, $acc[-1];\n    }\n\n    @bell;\n}\n\nsay join ', ', bell_numbers(15);\n\n__END__\n1, 1, 2, 5, 15, 52, 203, 877, 4140, 21147, 115975, 678570, 4213597, 27644437, 190899322, 1382958545\n"
  },
  {
    "path": "Math/bell_numbers_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Fast algorithm for computing the first `n` Bell numbers, using Aitken's array (optimized for space).\n\n# See also:\n#   https://en.wikipedia.org/wiki/Bell_number\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\nuse experimental qw(signatures);\n\nsub bell_numbers($n) {\n\n    my @acc;\n\n    my $t    = Math::GMPz::Rmpz_init();\n    my @bell = (Math::GMPz::Rmpz_init_set_ui(1));\n\n    foreach my $k (1 .. $n) {\n\n        Math::GMPz::Rmpz_set($t, $bell[-1]);\n\n        foreach my $item (@acc) {\n            Math::GMPz::Rmpz_add($t, $t, $item);\n            Math::GMPz::Rmpz_set($item, $t);\n        }\n\n        unshift @acc, Math::GMPz::Rmpz_init_set($bell[-1]);\n        push @bell, Math::GMPz::Rmpz_init_set($acc[-1]);\n    }\n\n    @bell;\n}\n\nsay join ', ', bell_numbers(15);\n\n__END__\n1, 1, 2, 5, 15, 52, 203, 877, 4140, 21147, 115975, 678570, 4213597, 27644437, 190899322, 1382958545\n"
  },
  {
    "path": "Math/bernoulli_denominators.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 13 May 2017\n# https://github.com/trizen\n\n# Fast computation of the denominator of the nth-Bernoulli number.\n\n# See also:\n#   https://oeis.org/A139822\n#   https://en.wikipedia.org/wiki/Von_Staudt%E2%80%93Clausen_theorem\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\nuse POSIX qw(ULONG_MAX);\nuse ntheory qw(fordivisors is_prob_prime);\n\nsub bernoulli_denominator {\n    my ($n) = @_;\n\n    return 1 if ($n == 0);\n    return 2 if ($n == 1);\n    return 1 if ($n % 2 == 1);\n\n    my $p = Math::GMPz::Rmpz_init();\n    my $d = Math::GMPz::Rmpz_init_set_ui(1);\n\n    fordivisors {\n        if ($_ >= ULONG_MAX) {\n            Math::GMPz::Rmpz_set_str($p, \"$_\", 10);\n            Math::GMPz::Rmpz_add_ui($p, $p, 1);\n\n            if (is_prob_prime($p)) {\n                Math::GMPz::Rmpz_mul($d, $d, $p);\n            }\n        }\n        else {\n            if (is_prob_prime($_ + 1)) {\n                Math::GMPz::Rmpz_mul_ui($d, $d, $_ + 1);    # d = d * p, where (p-1)|n\n            }\n        }\n    } $n;\n\n    return $d;\n}\n\nforeach my $n (0 .. 20) {\n    say \"denom(B(10^$n)) = \", bernoulli_denominator(Math::GMPz->new('1' . ('0' x $n)));\n}\n\n__END__\ndenom(B(10^0)) = 2\ndenom(B(10^1)) = 66\ndenom(B(10^2)) = 33330\ndenom(B(10^3)) = 342999030\ndenom(B(10^4)) = 2338224387510\ndenom(B(10^5)) = 9355235774427510\ndenom(B(10^6)) = 936123257411127577818510\ndenom(B(10^7)) = 9601480183016524970884020224910\ndenom(B(10^8)) = 394815332706046542049668428841497001870\ndenom(B(10^9)) = 24675958688943241584150818852261991458372001870\n"
  },
  {
    "path": "Math/bernoulli_denominators_records.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 11 January 2019\n# https://github.com/trizen\n\n# Fast program for computing the numbers `n` such that the denominator of Bernoulli(n) is a record.\n\n# OEIS sequences:\n#   https://oeis.org/A100195\n#   https://oeis.org/A100194\n\n# See also:\n#   https://en.wikipedia.org/wiki/Bernoulli_number\n#   https://mathworld.wolfram.com/BernoulliNumber.html\n#   https://en.wikipedia.org/wiki/Von_Staudt%E2%80%93Clausen_theorem\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(divisors is_prime vecprod);\n\nsub bernoulli_denominator ($n) {    # denominator of the n-th Bernoulli number\n\n    return 1 if ($n <= 0);\n    return 1 if ($n > 1 and $n % 2);\n\n    vecprod(map { $_ + 1 } grep { is_prime($_ + 1) } divisors($n));\n}\n\nsub records_upto ($n, $callback) {\n\n    for (my ($k, $m) = (0, -1) ; $k <= $n ; $k += 2) {\n\n        my $sum = 0;\n        foreach my $d (divisors($k)) {\n            if (is_prime($d + 1)) {\n                $sum += log($d + 1);\n            }\n        }\n\n        if ($sum > $m) {\n            $m = $sum;\n            $callback->($k);\n        }\n    }\n}\n\nrecords_upto(1e4, sub ($k) { say \"B($k) = \", bernoulli_denominator($k) });\n\n__END__\nB(0) = 2\nB(2) = 6\nB(4) = 30\nB(6) = 42\nB(10) = 66\nB(12) = 2730\nB(30) = 14322\nB(36) = 1919190\nB(60) = 56786730\nB(72) = 140100870\nB(108) = 209191710\nB(120) = 2328255930\nB(144) = 2381714790\nB(180) = 7225713885390\nB(240) = 9538864545210\nB(360) = 21626561658972270\nB(420) = 446617991732222310\nB(540) = 115471236091149548610\nB(840) = 5145485882746933233510\nB(1008) = 14493038256293268734790\nB(1080) = 345605409620810598989730\nB(1200) = 42107247672297314156359710\nB(1260) = 4554106624556364764691012210\nB(1620) = 24743736851520275624910204330\nB(1680) = 802787680649929796414310788070\nB(2016) = 1908324101335116127448341021830\nB(2160) = 1324918483651364394207119201026530\nB(2520) = 9655818125018463593525930077544596530\nB(3360) = 176139196253087613320507734410708168870\nB(3780) = 20880040554948303778681975110988542692370\nB(5040) = 1520038371910163024272084596792024938493098335890\nB(6480) = 2386506545702609292996755910476726098859145077130\nB(7560) = 334731403390662540713247087231623394273840419057927010\nB(8400) = 30721852291400450355987797336504062619723310330260297070\n"
  },
  {
    "path": "Math/bernoulli_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Akiyama–Tanigawa algorithm for computing the nth-Bernoulli number.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload);\n\n# Translation of:\n#   https://en.wikipedia.org/wiki/Bernoulli_number#Algorithmic_description\n\nsub bernoulli {\n    my ($n) = @_;\n\n    return 0 if $n > 1 && $n % 2;    # Bn = 0 for all odd n > 1\n\n    my @A;\n    for my $m (0 .. $n) {\n        $A[$m] = 1 / ($m + 1);\n\n        for (my $j = $m ; $j > 0 ; $j--) {\n            $A[$j - 1] = $j * ($A[$j - 1] - $A[$j]);\n        }\n    }\n\n    return $A[0];                    # which is Bn\n}\n\nforeach my $i (0 .. 50) {\n    printf \"B%-3d = %s\\n\", 2 * $i, bernoulli(2 * $i);\n}\n"
  },
  {
    "path": "Math/bernoulli_numbers_from_factorials.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 02 December 2017\n# https://github.com/trizen\n\n# A new algorithm for computing Bernoulli numbers.\n\n# Inspired from Norman J. Wildberger video lecture:\n#   https://www.youtube.com/watch?v=qmMs6tf8qZ8\n\n# See also:\n#   https://en.wikipedia.org/wiki/Bernoulli_number#Connection_with_Pascal’s_triangle\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload factorial bernfrac);\n\nsub bernoulli_numbers {\n    my ($n) = @_;\n\n    my @B = (1);\n\n    foreach my $i (1 .. $n) {\n        foreach my $k (0 .. $i - 1) {\n            $B[$i] //= 0;\n            $B[$i] -= $B[$k] / factorial($i - $k + 1);\n        }\n    }\n\n    map { $B[$_] * factorial($_) } 0 .. $#B;\n}\n\nmy @B = bernoulli_numbers(100);      # first 100 Bernoulli numbers\n\nforeach my $i (0 .. $#B) {\n\n    # Verify the results\n    if ($i > 1 and $B[$i] != bernfrac($i)) {\n        die \"error for i=$i\";\n    }\n\n    say \"B($i) = $B[$i]\";\n}\n"
  },
  {
    "path": "Math/bernoulli_numbers_from_factorials_mpq.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 02 December 2017\n# https://github.com/trizen\n\n# A new algorithm for computing Bernoulli numbers.\n\n# Inspired from Norman J. Wildberger video lecture:\n#   https://www.youtube.com/watch?v=qmMs6tf8qZ8\n\n# See also:\n#   https://en.wikipedia.org/wiki/Bernoulli_number#Connection_with_Pascal’s_triangle\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::GMPq;\nuse Math::GMPz;\n\nsub bernoulli_numbers {\n    my ($n) = @_;\n\n    my @B;\n    my @factorial;\n\n    Math::GMPq::Rmpq_set_ui($B[0]  = Math::GMPq::Rmpq_init(), 1, 1);\n    Math::GMPq::Rmpq_set_ui($B[$_] = Math::GMPq::Rmpq_init(), 0, 1) for (1 .. $n);\n\n    my $t = Math::GMPq::Rmpq_init();\n\n    foreach my $i (1 .. $n) {\n\n        if ($i % 2 != 0 and $i > 1) {\n            next;\n        }\n\n        foreach my $k (0 .. $i - 1) {\n\n            if ($k % 2 != 0 and $k > 1) {\n                next;\n            }\n\n            my $r = $i - $k + 1;\n\n            $factorial[$r] //= do {\n                my $t = Math::GMPz::Rmpz_init();\n                Math::GMPz::Rmpz_fac_ui($t, $r);\n                $t;\n            };\n\n            Math::GMPq::Rmpq_div_z($t, $B[$k], $factorial[$r]);\n            Math::GMPq::Rmpq_sub($B[$i], $B[$i], $t);\n        }\n    }\n\n    for (my $k = 2; $k <= $#B; $k += 2) {\n        Math::GMPq::Rmpq_mul_z($B[$k], $B[$k], $factorial[$k]);\n    }\n\n    return @B;\n}\n\nmy @B = bernoulli_numbers(100);    # first 100 Bernoulli numbers\n\nforeach my $i (0 .. $#B) {\n    say \"B($i) = $B[$i]\";\n}\n"
  },
  {
    "path": "Math/bernoulli_numbers_from_factorials_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 07 July 2018\n# https://github.com/trizen\n\n# A new algorithm for computing Bernoulli numbers.\n\n# Inspired from Norman J. Wildberger video lecture:\n#   https://www.youtube.com/watch?v=qmMs6tf8qZ8\n\n# See also:\n#   https://en.wikipedia.org/wiki/Bernoulli_number#Connection_with_Pascal’s_triangle\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::GMPq;\nuse Math::GMPz;\n\nsub bernoulli_numbers {\n    my ($n) = @_;\n\n    my @A = (Math::GMPz::Rmpz_init_set_ui(1));\n    my @B = (Math::GMPz::Rmpz_init_set_ui(1));\n    my @F = (Math::GMPz::Rmpz_init_set_ui(1));\n\n    foreach my $k (1 .. $n) {\n\n        $F[$k] = Math::GMPz::Rmpz_init();\n        $A[$k] = Math::GMPz::Rmpz_init_set_ui(0);\n        $B[$k] = Math::GMPz::Rmpz_init_set_ui(1);\n\n        Math::GMPz::Rmpz_mul_ui($F[$k], $F[$k - 1], $k);\n    }\n\n    Math::GMPz::Rmpz_mul_ui($F[$n + 1] = Math::GMPz::Rmpz_init(), $F[$n], $n + 1);\n\n    my $t = Math::GMPz::Rmpz_init();\n\n    foreach my $i (1 .. $n) {\n\n        if ($i % 2 != 0 and $i > 1) {\n            next;\n        }\n\n        foreach my $k (0 .. $i - 1) {\n\n            if ($k % 2 != 0 and $k > 1) {\n                next;\n            }\n\n            my $r = $i - $k + 1;\n\n            Math::GMPz::Rmpz_mul($A[$i], $A[$i], $F[$r]);\n            Math::GMPz::Rmpz_mul($A[$i], $A[$i], $B[$k]);\n            Math::GMPz::Rmpz_submul($A[$i], $B[$i], $A[$k]);\n            Math::GMPz::Rmpz_mul($B[$i], $B[$i], $F[$r]);\n            Math::GMPz::Rmpz_mul($B[$i], $B[$i], $B[$k]);\n\n            Math::GMPz::Rmpz_gcd($t, $A[$i], $B[$i]);\n            Math::GMPz::Rmpz_divexact($A[$i], $A[$i], $t);\n            Math::GMPz::Rmpz_divexact($B[$i], $B[$i], $t);\n        }\n    }\n\n    my @R = @A;\n\n    for (my $k = 2 ; $k <= $#B ; $k += 2) {\n        Math::GMPz::Rmpz_mul($A[$k], $A[$k], $F[$k]);\n\n        my $bern = Math::GMPq::Rmpq_init();\n        Math::GMPq::Rmpq_set_num($bern, $A[$k]);\n        Math::GMPq::Rmpq_set_den($bern, $B[$k]);\n        Math::GMPq::Rmpq_canonicalize($bern);\n\n        $R[$k] = $bern;\n    }\n\n    if ($#R > 0) {\n        my $bern = Math::GMPq::Rmpq_init();\n        Math::GMPq::Rmpq_set_num($bern, $A[1]);\n        Math::GMPq::Rmpq_set_den($bern, $B[1]);\n        Math::GMPq::Rmpq_canonicalize($bern);\n        $R[1] = $bern;\n    }\n\n    return @R;\n}\n\nmy @B = bernoulli_numbers(100);    # first 100 Bernoulli numbers\n\nforeach my $i (0 .. $#B) {\n    say \"B($i) = $B[$i]\";\n}\n"
  },
  {
    "path": "Math/bernoulli_numbers_from_factorials_visual.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 02 December 2017\n# https://github.com/trizen\n\n# A new algorithm for computing Bernoulli numbers (visualization).\n\n# Inspired from Norman J. Wildberger video lecture:\n#   https://www.youtube.com/watch?v=qmMs6tf8qZ8\n\n# See also:\n#   https://en.wikipedia.org/wiki/Bernoulli_number#Connection_with_Pascal’s_triangle\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload factorial bernfrac);\n\nsub bernoulli_numbers {\n    my ($n) = @_;\n\n    my @B = (1, (0) x $n);\n\n    foreach my $i (1 .. $n) {\n\n        if ($i % 2 != 0 and $i > 1) {\n            ## next;\n        }\n\n        foreach my $k (0 .. $i - 1) {\n\n            if ($k % 2 != 0 and $k > 1) {\n                ## next;\n            }\n\n            my $f = factorial($i - $k + 1);\n            my $d = $B[$i] - $B[$k] / $f;\n\n            printf(\"[%2s, %s] -> %6s / %2s! - %6s / %s!  / %2s! = %6s  / %2s!\\n\",\n                   $i, $k, $B[$i] * factorial($i),\n                   $i, $B[$k] * factorial($k),\n                   $k,\n                   $i - $k + 1,\n                   $d * factorial($i), $i);\n\n            $B[$i] = $d;\n        }\n\n        say '';\n    }\n\n    map { $B[$_] * factorial($_) } 0 .. $#B;\n}\n\nmy @B = bernoulli_numbers(10);    # first 10 Bernoulli numbers\n\nforeach my $i (0 .. $#B) {\n\n    # Verify the results\n    if ($i > 1 and $B[$i] != bernfrac($i)) {\n        die \"error for i=$i\";\n    }\n\n    say \"B($i) = $B[$i]\";\n}\n\n__END__\n[ 1, 0] ->      0 /  1! -      1 / 0!  /  2! =   -1/2  /  1!\n\n[ 2, 0] ->      0 /  2! -      1 / 0!  /  3! =   -1/3  /  2!\n[ 2, 1] ->   -1/3 /  2! -   -1/2 / 1!  /  2! =    1/6  /  2!\n\n[ 3, 0] ->      0 /  3! -      1 / 0!  /  4! =   -1/4  /  3!\n[ 3, 1] ->   -1/4 /  3! -   -1/2 / 1!  /  3! =    1/4  /  3!\n[ 3, 2] ->    1/4 /  3! -    1/6 / 2!  /  2! =      0  /  3!\n\n[ 4, 0] ->      0 /  4! -      1 / 0!  /  5! =   -1/5  /  4!\n[ 4, 1] ->   -1/5 /  4! -   -1/2 / 1!  /  4! =   3/10  /  4!\n[ 4, 2] ->   3/10 /  4! -    1/6 / 2!  /  3! =  -1/30  /  4!\n[ 4, 3] ->  -1/30 /  4! -      0 / 3!  /  2! =  -1/30  /  4!\n\n[ 5, 0] ->      0 /  5! -      1 / 0!  /  6! =   -1/6  /  5!\n[ 5, 1] ->   -1/6 /  5! -   -1/2 / 1!  /  5! =    1/3  /  5!\n[ 5, 2] ->    1/3 /  5! -    1/6 / 2!  /  4! =  -1/12  /  5!\n[ 5, 3] ->  -1/12 /  5! -      0 / 3!  /  3! =  -1/12  /  5!\n[ 5, 4] ->  -1/12 /  5! -  -1/30 / 4!  /  2! =      0  /  5!\n\n[ 6, 0] ->      0 /  6! -      1 / 0!  /  7! =   -1/7  /  6!\n[ 6, 1] ->   -1/7 /  6! -   -1/2 / 1!  /  6! =   5/14  /  6!\n[ 6, 2] ->   5/14 /  6! -    1/6 / 2!  /  5! =   -1/7  /  6!\n[ 6, 3] ->   -1/7 /  6! -      0 / 3!  /  4! =   -1/7  /  6!\n[ 6, 4] ->   -1/7 /  6! -  -1/30 / 4!  /  3! =   1/42  /  6!\n[ 6, 5] ->   1/42 /  6! -      0 / 5!  /  2! =   1/42  /  6!\n\n[ 7, 0] ->      0 /  7! -      1 / 0!  /  8! =   -1/8  /  7!\n[ 7, 1] ->   -1/8 /  7! -   -1/2 / 1!  /  7! =    3/8  /  7!\n[ 7, 2] ->    3/8 /  7! -    1/6 / 2!  /  6! =  -5/24  /  7!\n[ 7, 3] ->  -5/24 /  7! -      0 / 3!  /  5! =  -5/24  /  7!\n[ 7, 4] ->  -5/24 /  7! -  -1/30 / 4!  /  4! =   1/12  /  7!\n[ 7, 5] ->   1/12 /  7! -      0 / 5!  /  3! =   1/12  /  7!\n[ 7, 6] ->   1/12 /  7! -   1/42 / 6!  /  2! =      0  /  7!\n\n[ 8, 0] ->      0 /  8! -      1 / 0!  /  9! =   -1/9  /  8!\n[ 8, 1] ->   -1/9 /  8! -   -1/2 / 1!  /  8! =   7/18  /  8!\n[ 8, 2] ->   7/18 /  8! -    1/6 / 2!  /  7! =  -5/18  /  8!\n[ 8, 3] ->  -5/18 /  8! -      0 / 3!  /  6! =  -5/18  /  8!\n[ 8, 4] ->  -5/18 /  8! -  -1/30 / 4!  /  5! =  17/90  /  8!\n[ 8, 5] ->  17/90 /  8! -      0 / 5!  /  4! =  17/90  /  8!\n[ 8, 6] ->  17/90 /  8! -   1/42 / 6!  /  3! =  -1/30  /  8!\n[ 8, 7] ->  -1/30 /  8! -      0 / 7!  /  2! =  -1/30  /  8!\n\n[ 9, 0] ->      0 /  9! -      1 / 0!  / 10! =  -1/10  /  9!\n[ 9, 1] ->  -1/10 /  9! -   -1/2 / 1!  /  9! =    2/5  /  9!\n[ 9, 2] ->    2/5 /  9! -    1/6 / 2!  /  8! =  -7/20  /  9!\n[ 9, 3] ->  -7/20 /  9! -      0 / 3!  /  7! =  -7/20  /  9!\n[ 9, 4] ->  -7/20 /  9! -  -1/30 / 4!  /  6! =   7/20  /  9!\n[ 9, 5] ->   7/20 /  9! -      0 / 5!  /  5! =   7/20  /  9!\n[ 9, 6] ->   7/20 /  9! -   1/42 / 6!  /  4! =  -3/20  /  9!\n[ 9, 7] ->  -3/20 /  9! -      0 / 7!  /  3! =  -3/20  /  9!\n[ 9, 8] ->  -3/20 /  9! -  -1/30 / 8!  /  2! =      0  /  9!\n\n[10, 0] ->      0 / 10! -      1 / 0!  / 11! =  -1/11  / 10!\n[10, 1] ->  -1/11 / 10! -   -1/2 / 1!  / 10! =   9/22  / 10!\n[10, 2] ->   9/22 / 10! -    1/6 / 2!  /  9! = -14/33  / 10!\n[10, 3] -> -14/33 / 10! -      0 / 3!  /  8! = -14/33  / 10!\n[10, 4] -> -14/33 / 10! -  -1/30 / 4!  /  7! =  19/33  / 10!\n[10, 5] ->  19/33 / 10! -      0 / 5!  /  6! =  19/33  / 10!\n[10, 6] ->  19/33 / 10! -   1/42 / 6!  /  5! = -14/33  / 10!\n[10, 7] -> -14/33 / 10! -      0 / 7!  /  4! = -14/33  / 10!\n[10, 8] -> -14/33 / 10! -  -1/30 / 8!  /  3! =   5/66  / 10!\n[10, 9] ->   5/66 / 10! -      0 / 9!  /  2! =   5/66  / 10!\n\nB(0) = 1\nB(1) = -1/2\nB(2) = 1/6\nB(3) = 0\nB(4) = -1/30\nB(5) = 0\nB(6) = 1/42\nB(7) = 0\nB(8) = -1/30\nB(9) = 0\nB(10) = 5/66\n"
  },
  {
    "path": "Math/bernoulli_numbers_from_primes.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 13 May 2017\n# https://github.com/trizen\n\n# A very high-level computation of the nth-Bernoulli number, using prime numbers.\n\n# Algorithm due to Kevin J. McGown (December 8, 2005)\n# See his paper: \"Computing Bernoulli Numbers Quickly\"\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(factorial next_prime ceil float is_div);\n\nsub bern_from_primes {\n    my ($n) = @_;\n\n    $n == 0 and return Math::AnyNum->one;\n    $n == 1 and return Math::AnyNum->new('1/2');\n    $n <  0 and return Math::AnyNum->nan;\n    $n %  2 and return Math::AnyNum->zero;\n\n    my $tau   = 6.28318530717958647692528676655900576839433879875;\n    my $log2B = (log(4 * $tau * $n) / 2 + $n * log($n) - $n * log($tau) - $n) / log(2);\n\n    local $Math::AnyNum::PREC = int($n + $log2B) + ($n <= 90 ? 18 : 0);\n\n    my $K = factorial($n) * 2 / Math::AnyNum->tau**$n;\n    my $d = 1;\n\n    for (my $p = 2 ; $p <= $n + 1 ; $p = next_prime($p)) {\n        if (is_div($n, $p - 1)) {\n            $d *= $p;\n        }\n    }\n\n    my $N = ceil(($K * $d)->root($n - 1));\n\n    my $z = 1.0;\n    for (my $p = 2 ; $p <= $N ; $p = next_prime($p)) {\n        my $u = float($p)**$n;\n        $z *= $u / ($u-1);\n    }\n\n    (-1)**($n / 2 + 1) * int(ceil($d * $K * $z)) / $d;\n}\n\nforeach my $n (0 .. 50) {\n    printf \"B%-3d = %s\\n\", 2 * $n, bern_from_primes(2 * $n);\n}\n"
  },
  {
    "path": "Math/bernoulli_numbers_from_primes_gmpf.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 14 November 2017\n# https://github.com/trizen\n\n# Efficient algorithm for computing the nth-Bernoulli number, using prime numbers.\n\n# Algorithm due to Kevin J. McGown (December 8, 2005)\n# See his paper: \"Computing Bernoulli Numbers Quickly\"\n\n# Run times:\n#   bern( 40_000) - 2.763s\n#   bern(100_000) - 19.591s\n#   bern(200_000) - 1 min, 27.21s\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\nuse Math::GMPq;\nuse Math::GMPf;\nuse Math::MPFR;\n\nsub bern_from_primes {\n    my ($n) = @_;\n\n    $n == 0 and return Math::GMPq->new('1');\n    $n == 1 and return Math::GMPq->new('1/2');\n    $n <  0 and return undef;\n    $n %  2 and return Math::GMPq->new('0');\n\n    state $round = Math::MPFR::MPFR_RNDN();\n    state $tau   = 6.28318530717958647692528676655900576839433879875;\n\n    my $log2B = (CORE::log(4 * $tau * $n) / 2 + $n * (CORE::log($n / $tau) - 1)) / CORE::log(2);\n\n    my $prec = CORE::int($n + $log2B) +\n          ($n <= 90 ? (3, 3, 4, 4, 7, 6, 6, 6, 7, 7, 7, 8, 8, 9, 10, 12, 9, 7, 6, 0, 0, 0,\n                       0, 0, 0, 0, 0, 3, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4)[($n>>1)-1] : 0);\n\n    state $d = Math::GMPz::Rmpz_init_nobless();\n    Math::GMPz::Rmpz_fac_ui($d, $n);                      # d = n!\n\n    my $K = Math::MPFR::Rmpfr_init2($prec);\n    Math::MPFR::Rmpfr_const_pi($K, $round);               # K = pi\n    Math::MPFR::Rmpfr_pow_si($K, $K, -$n, $round);        # K = K^(-n)\n    Math::MPFR::Rmpfr_mul_z($K, $K, $d, $round);          # K = K*d\n    Math::MPFR::Rmpfr_div_2ui($K, $K, $n - 1, $round);    # K = K / 2^(n-1)\n\n    # `d` is the denominator of bernoulli(n)\n    Math::GMPz::Rmpz_set_ui($d, 2);                       # d = 2\n\n    my @primes = (2);\n\n    {\n        # Sieve the primes <= n+1\n        # Sieve of Eratosthenes + Dana Jacobsen's optimizations\n\n        my $N = $n + 1;\n\n        my @composite;\n        my $bound = CORE::int(CORE::sqrt($N));\n\n        for (my $i = 3 ; $i <= $bound ; $i += 2) {\n            if (!exists($composite[$i])) {\n                for (my $j = $i * $i ; $j <= $N ; $j += 2 * $i) {\n                    undef $composite[$j];\n                }\n            }\n        }\n\n        foreach my $k (1 .. ($N - 1) >> 1) {\n            if (!exists($composite[2 * $k + 1])) {\n\n                push(@primes, 2 * $k + 1);\n\n                if ($n % (2 * $k) == 0) {    # d = d*p   iff (p-1)|n\n                    Math::GMPz::Rmpz_mul_ui($d, $d, 2 * $k + 1);\n                }\n            }\n        }\n    }\n\n    state $N = Math::MPFR::Rmpfr_init2_nobless(64);\n    Math::MPFR::Rmpfr_mul_z($K, $K, $d, $round);         # K = K*d\n    Math::MPFR::Rmpfr_rootn_ui($N, $K, $n - 1, $round);  # N = N^(1/(n-1))\n    Math::MPFR::Rmpfr_ceil($N, $N);                      # N = ceil(N)\n\n    my $bound = Math::MPFR::Rmpfr_get_ui($N, $round);    # bound = int(N)\n\n    my $t = Math::GMPf::Rmpf_init2($prec);               # temporary variable\n    my $f = Math::GMPf::Rmpf_init2($prec);               # approximation to zeta(n)\n\n    Math::MPFR::Rmpfr_get_f($f, $K, $round);\n\n    for (my $i = 0 ; $primes[$i] <= $bound ; ++$i) {  # primes <= N\n        Math::GMPf::Rmpf_set_ui($t, $primes[$i]);        # t = p\n        Math::GMPf::Rmpf_pow_ui($t, $t, $n);             # t = t^n\n        Math::GMPf::Rmpf_mul($f, $f, $t);                # f = f*t\n        Math::GMPf::Rmpf_sub_ui($t, $t, 1);              # t = t-1\n        Math::GMPf::Rmpf_div($f, $f, $t);                # f = f/t\n    }\n\n    my $q = Math::GMPq::Rmpq_init();\n\n    Math::GMPf::Rmpf_ceil($f, $f);                       # f = ceil(f)\n    Math::GMPq::Rmpq_set_f($q, $f);                      # q = f\n\n    Math::GMPq::Rmpq_set_den($q, $d);                    # denominator\n    Math::GMPq::Rmpq_neg($q, $q) if $n % 4 == 0;         # q = -q, iff 4|n\n\n    return $q;                                           # Bn\n}\n\nforeach my $i (0 .. 50) {\n    printf \"B%-3d = %s\\n\", 2 * $i, bern_from_primes(2 * $i);\n}\n"
  },
  {
    "path": "Math/bernoulli_numbers_from_primes_mpfr.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 13 May 2017\n# https://github.com/trizen\n\n# Computation of the nth-Bernoulli number, using prime numbers.\n\n# Algorithm due to Kevin J. McGown (December 8, 2005)\n# See his paper: \"Computing Bernoulli Numbers Quickly\"\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\nuse Math::GMPq;\nuse Math::MPFR;\n\nsub bern_from_primes {\n    my ($n) = @_;\n\n    $n == 0 and return Math::GMPq->new('1');\n    $n == 1 and return Math::GMPq->new('1/2');\n    $n <  0 and return undef;\n    $n %  2 and return Math::GMPq->new('0');\n\n    my $round = Math::MPFR::MPFR_RNDN();\n\n    my $tau   = 6.28318530717958647692528676655900576839433879875;\n    my $log2B = (log(4 * $tau * $n) / 2 + $n * log($n) - $n * log($tau) - $n) / log(2);\n\n    my $prec = int($n + $log2B) + ($n <= 90 ? 18 : 0);\n\n    my $d = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_fac_ui($d, $n);                      # d = n!\n\n    my $K = Math::MPFR::Rmpfr_init2($prec);\n    Math::MPFR::Rmpfr_const_pi($K, $round);               # K = pi\n    Math::MPFR::Rmpfr_pow_si($K, $K, -$n, $round);        # K = K^(-n)\n    Math::MPFR::Rmpfr_mul_z($K, $K, $d, $round);          # K = K*d\n    Math::MPFR::Rmpfr_div_2ui($K, $K, $n - 1, $round);    # K = K / 2^(n-1)\n\n    Math::GMPz::Rmpz_set_ui($d, 1);                       # d = 1\n\n    my @primes;\n\n    {  # Sieve the primes <= n+1\n        my @composite;\n        foreach my $i (2 .. sqrt($n) + 1) {\n            if (!$composite[$i]) {\n                for (my $j = $i**2 ; $j <= $n + 1 ; $j += $i) {\n                    $composite[$j] = 1;\n                }\n            }\n        }\n\n        foreach my $p (2 .. $n + 1) {\n            if (!$composite[$p]) {\n\n                if ($n % ($p - 1) == 0) {\n                    Math::GMPz::Rmpz_mul_ui($d, $d, $p);    # d = d*p   iff (p-1)|n\n                }\n\n                push @primes, $p;\n            }\n        }\n    }\n\n    my $N = Math::MPFR::Rmpfr_init2(64);\n    Math::MPFR::Rmpfr_mul_z($N, $K, $d, $round);            # N = K*d\n    Math::MPFR::Rmpfr_rootn_ui($N, $N, $n - 1, $round);     # N = N^(1/(n-1))\n    Math::MPFR::Rmpfr_ceil($N, $N);                         # N = ceil(N)\n\n    $N = Math::MPFR::Rmpfr_get_ui($N, $round);              # N = int(N)\n\n    my $z = Math::MPFR::Rmpfr_init2($prec);                 # zeta(n)\n    my $u = Math::GMPz::Rmpz_init();                        # p^n\n\n    Math::MPFR::Rmpfr_set_ui($z, 1, $round);                # z = 1\n\n    #~ my $t1 = Math::MPFR::Rmpfr_init2($prec);\n    #~ my $t2 = Math::MPFR::Rmpfr_init2($prec);\n\n    for (my $i = 0 ; $primes[$i] <= $N ; ++$i) {            # primes <= N\n\n        #~ # Version 1\n        #~ # 1 min, 45.29s for bern(200_000)\n        #~ Math::MPFR::Rmpfr_ui_pow_ui($t1, $primes[$i], $n, $round);    # t1 = p^n\n        #~ Math::MPFR::Rmpfr_sub_ui($t2, $t1, 1, $round);                # t2 = t1 - 1\n        #~ Math::MPFR::Rmpfr_div($t1, $t1, $t2, $round);                 # t1 = t1 / t2\n        #~ Math::MPFR::Rmpfr_mul($z, $z, $t1, $round);                   # z  = z * t1\n\n        #~ # Version 2\n        #~ # 1 min, 42.54s for bern(200_000)\n        #~ Math::MPFR::Rmpfr_ui_pow_ui($t1, $primes[$i], $n, $round);    # t1 = p^n\n        #~ Math::MPFR::Rmpfr_mul($z, $z, $t1, $round);                   # z  = z*t1\n        #~ Math::MPFR::Rmpfr_sub_ui($t1, $t1, 1, $round);                # t1 = t1-1\n        #~ Math::MPFR::Rmpfr_div($z, $z, $t1, $round);                   # z  = z/t1\n\n        # Version 3 (fastest)\n        # 1 min, 39.23s for bern(200_000)\n        Math::GMPz::Rmpz_ui_pow_ui($u, $primes[$i], $n);    # u = p^n\n        Math::MPFR::Rmpfr_mul_z($z, $z, $u, $round);        # z = z*u\n        Math::GMPz::Rmpz_sub_ui($u, $u, 1);                 # u = u-1\n        Math::MPFR::Rmpfr_div_z($z, $z, $u, $round);        # z = z/u\n    }\n\n    Math::MPFR::Rmpfr_mul($z, $z, $K, $round);              # z = z * K\n    Math::MPFR::Rmpfr_mul_z($z, $z, $d, $round);            # z = z * d\n    Math::MPFR::Rmpfr_ceil($z, $z);                         # z = ceil(z)\n\n    my $q = Math::GMPq::Rmpq_init();\n\n    Math::GMPq::Rmpq_set_den($q, $d);                       # denominator\n    Math::MPFR::Rmpfr_get_z($d, $z, $round);\n    Math::GMPz::Rmpz_neg($d, $d) if $n % 4 == 0;            # d = -d, iff 4|n\n    Math::GMPq::Rmpq_set_num($q, $d);                       # numerator\n\n    return $q;                                              # Bn\n}\n\nforeach my $i (0 .. 50) {\n    printf \"B%-3d = %s\\n\", 2 * $i, bern_from_primes(2 * $i);\n}\n"
  },
  {
    "path": "Math/bernoulli_numbers_from_primes_ntheory.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 13 May 2017\n# https://github.com/trizen\n\n# Computation of the nth-Bernoulli number, using prime numbers.\n\n# Algorithm due to Kevin J. McGown (December 8, 2005)\n# See his paper: \"Computing Bernoulli Numbers Quickly\"\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\nuse Math::GMPq;\nuse Math::MPFR;\n\nuse ntheory qw(is_prob_prime forprimes fordivisors);\n\nsub bern_from_primes {\n    my ($n) = @_;\n\n    $n == 0 and return Math::GMPq->new('1');\n    $n == 1 and return Math::GMPq->new('1/2');\n    $n <  0 and return undef;\n    $n %  2 and return Math::GMPq->new('0');\n\n    my $round = Math::MPFR::MPFR_RNDN();\n\n    my $tau   = 6.28318530717958647692528676655900576839433879875;\n    my $log2B = (log(4 * $tau * $n) / 2 + $n * log($n) - $n * log($tau) - $n) / log(2);\n\n    my $prec = int($n + $log2B) + ($n <= 90 ? 18 : 0);\n\n    my $d = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_fac_ui($d, $n);                      # d = n!\n\n    my $K = Math::MPFR::Rmpfr_init2($prec);\n    Math::MPFR::Rmpfr_const_pi($K, $round);               # K = pi\n    Math::MPFR::Rmpfr_pow_ui($K, $K, $n, $round);         # K = K^n\n    Math::MPFR::Rmpfr_mul_2ui($K, $K, $n - 1, $round);    # K = K * 2^(n-1)\n    Math::MPFR::Rmpfr_div_z($K, $K, $d, $round);          # K = K / d\n    Math::MPFR::Rmpfr_ui_div($K, 1, $K, $round);          # K = 1 / K\n\n    Math::GMPz::Rmpz_set_ui($d, 1);                       # d = 1\n\n    fordivisors {                                         # divisors of n\n        if (is_prob_prime($_ + 1)) {\n            Math::GMPz::Rmpz_mul_ui($d, $d, $_ + 1);      # d = d * p, where (p-1)|n\n        }\n    } $n;\n\n    my $N = Math::MPFR::Rmpfr_init2(64);\n    Math::MPFR::Rmpfr_mul_z($N, $K, $d, $round);          # N = K * d\n    Math::MPFR::Rmpfr_rootn_ui($N, $N, $n - 1, $round);   # N = K^(1/(n-1))\n    Math::MPFR::Rmpfr_ceil($N, $N);                       # N = ceil(N)\n\n    $N = Math::MPFR::Rmpfr_get_ui($N, $round);\n\n    my $z = Math::MPFR::Rmpfr_init2($prec);               # zeta(n)\n    my $u = Math::GMPz::Rmpz_init();                      # p^n\n\n    Math::MPFR::Rmpfr_set_ui($z, 1, $round);              # z = 1\n\n    forprimes {                                           # primes <= N\n        Math::GMPz::Rmpz_ui_pow_ui($u, $_, $n);           # u = p^n\n        Math::MPFR::Rmpfr_mul_z($z, $z, $u, $round);      # z = z*u\n        Math::GMPz::Rmpz_sub_ui($u, $u, 1);               # u = u-1\n        Math::MPFR::Rmpfr_div_z($z, $z, $u, $round);      # z = z/u\n    } $N;\n\n    Math::MPFR::Rmpfr_mul($z, $z, $K, $round);            # z = z * K\n    Math::MPFR::Rmpfr_mul_z($z, $z, $d, $round);          # z = z * d\n    Math::MPFR::Rmpfr_ceil($z, $z);                       # z = ceil(z)\n\n    my $q = Math::GMPq::Rmpq_init();\n\n    Math::GMPq::Rmpq_set_den($q, $d);                     # denominator\n    Math::MPFR::Rmpfr_get_z($d, $z, $round);\n    Math::GMPz::Rmpz_neg($d, $d) if $n % 4 == 0;          # d = -d, iff 4|n\n    Math::GMPq::Rmpq_set_num($q, $d);                     # numerator\n\n    return $q;                                            # Bn\n}\n\nforeach my $i (0 .. 50) {\n    printf \"B%-3d = %s\\n\", 2 * $i, bern_from_primes(2 * $i);\n}\n"
  },
  {
    "path": "Math/bernoulli_numbers_from_tangent_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Algorithm for computing the Bernoulli numbers from the tangent numbers.\n\n# Algorithm presented in the book:\n#\n#   Modern Computer Arithmetic\n#           - by Richard P. Brent and Paul Zimmermann\n#\n\n# See also:\n#   https://oeis.org/A000182\n#   https://mathworld.wolfram.com/TangentNumber.html\n#   https://en.wikipedia.org/wiki/Alternating_permutation\n#   https://en.wikipedia.org/wiki/Bernoulli_number\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\nuse Math::GMPq;\n\nsub bernoulli_number {\n    my ($N) = @_;\n\n    my $q = Math::GMPq::Rmpq_init();\n\n    if ($N == 0) {\n        Math::GMPq::Rmpq_set_ui($q, 1, 1);\n        return $q;\n    }\n\n    if ($N == 1) {\n        Math::GMPq::Rmpq_set_si($q, -1, 2);\n        return $q;\n    }\n\n    if ($N & 1) {\n        Math::GMPq::Rmpq_set_ui($q, 0, 1);\n        return $q;\n    }\n\n    my $n = ($N >> 1) - 1;\n    my @T = (Math::GMPz::Rmpz_init_set_ui(1));\n\n    foreach my $k (1 .. $n) {\n        Math::GMPz::Rmpz_mul_ui($T[$k] = Math::GMPz::Rmpz_init(), $T[$k - 1], $k);\n    }\n\n    foreach my $k (1 .. $n) {\n        foreach my $j ($k .. $n) {\n            Math::GMPz::Rmpz_mul_ui($T[$j], $T[$j], $j - $k + 2);\n            Math::GMPz::Rmpz_addmul_ui($T[$j], $T[$j - 1], $j - $k);\n        }\n    }\n\n    my $t = $T[-1];\n    Math::GMPz::Rmpz_mul_ui($t, $t, $N);\n    Math::GMPz::Rmpz_neg($t, $t) if ($n & 1);\n    Math::GMPq::Rmpq_set_z($q, $t);\n\n    # z = (2^n - 1) * 2^n\n    my $z = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_setbit($z, $N);\n    Math::GMPz::Rmpz_sub_ui($z, $z, 1);\n    Math::GMPz::Rmpz_mul_2exp($z, $z, $N);\n\n    Math::GMPq::Rmpq_div_z($q, $q, $z);\n\n    return $q;\n}\n\nforeach my $n (1 .. 50) {\n    printf(\"B(%s) = %s\\n\", 2 * $n, bernoulli_number(2 * $n));\n}\n"
  },
  {
    "path": "Math/bernoulli_numbers_from_zeta.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 13 October 2016\n# Website: https://github.com/trizen\n\n# Computation of the nth-Bernoulli number, using the Zeta function.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum;\n\nsub bern_zeta {\n    my ($n) = @_;\n\n    # B(n) = (-1)^(n/2 + 1) * zeta(n)*2*n! / (2*pi)^n\n\n    $n == 0 and return Math::AnyNum->one;\n    $n == 1 and return Math::AnyNum->new('1/2');\n    $n < 0  and return Math::AnyNum->nan;\n    $n % 2  and return Math::AnyNum->zero;\n\n    my $ROUND = Math::MPFR::MPFR_RNDN();\n\n    # The required precision is: O(n*log(n))\n    my $prec = (\n        $n <= 156\n        ? CORE::int($n * CORE::log($n) + 1)\n        : CORE::int($n * CORE::log($n) / CORE::log(2) - 3 * $n)\n    );\n\n    my $f = Math::MPFR::Rmpfr_init2($prec);\n    Math::MPFR::Rmpfr_zeta_ui($f, $n, $ROUND);                     # f = zeta(n)\n\n    my $z = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_fac_ui($z, $n);                               # z = n!\n    Math::GMPz::Rmpz_div_2exp($z, $z, $n - 1);                     # z = z / 2^(n-1)\n    Math::MPFR::Rmpfr_mul_z($f, $f, $z, $ROUND);                   # f = f*z\n\n    my $p = Math::MPFR::Rmpfr_init2($prec);\n    Math::MPFR::Rmpfr_const_pi($p, $ROUND);                        # p = PI\n    Math::MPFR::Rmpfr_pow_ui($p, $p, $n, $ROUND);                  # p = p^n\n    Math::MPFR::Rmpfr_div($f, $f, $p, $ROUND);                     # f = f/p\n\n    Math::GMPz::Rmpz_set_ui($z, 1);                                # z = 1\n    Math::GMPz::Rmpz_mul_2exp($z, $z, $n + 1);                     # z = 2^(n+1)\n    Math::GMPz::Rmpz_sub_ui($z, $z, 2);                            # z = z-2\n\n    Math::MPFR::Rmpfr_mul_z($f, $f, $z, $ROUND);                   # f = f*z\n    Math::MPFR::Rmpfr_round($f, $f);                               # f = [f]\n\n    my $q = Math::GMPq::Rmpq_init();\n    Math::MPFR::Rmpfr_get_q($q, $f);                               # q = f\n    Math::GMPq::Rmpq_set_den($q, $z);                              # q = q/z\n    Math::GMPq::Rmpq_canonicalize($q);                             # remove common factors\n\n    Math::GMPq::Rmpq_neg($q, $q) if $n % 4 == 0;                   # q = -q    (iff 4|n)\n    Math::AnyNum->new($q);\n}\n\nforeach my $i (0 .. 50) {\n    printf \"B%-3d = %s\\n\", 2 * $i, bern_zeta(2 * $i);\n}\n"
  },
  {
    "path": "Math/bernoulli_numbers_ramanujan_congruences.pl",
    "content": "#!/usr/bin/perl\n\n# Formula due to Ramanujan for computing the nth-Bernoulli number.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Bernoulli_number#Ramanujan's_congruences\n\nuse 5.020;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload sum binomial);\n\nsub ramanujan_bernoulli_number ($n, $cache = {}) {\n\n    return 1/2 if ($n   == 1);\n    return 0   if ($n%2 == 1);\n\n    $cache->{$n} //= do {\n        (($n%6 == 4 ? -1/2 : 1) * ($n+3)/3 -\n            sum(map {\n                binomial($n+3, $n - 6*$_) * __SUB__->($n - 6*$_, $cache)\n            } 1 .. ($n - $n%6) / 6)\n        ) / binomial($n+3, $n)\n    };\n}\n\nforeach my $i (0 .. 50) {\n    printf \"B%-3d = %s\\n\", 2 * $i, ramanujan_bernoulli_number(2 * $i);\n}\n"
  },
  {
    "path": "Math/bernoulli_numbers_ramanujan_congruences_unreduced.pl",
    "content": "#!/usr/bin/perl\n\n# Formula due to Ramanujan for computing the nth-Bernoulli number.\n\n# This are the unreduced fractions.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Bernoulli_number#Ramanujan's_congruences\n\nuse 5.020;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse List::Util qw(sum);\nuse Math::Bacovia qw(Fraction Number);\nuse Math::AnyNum qw(binomial bernfrac);\n\nsub ramanujan_bernoulli_number ($n, $cache = {}) {\n\n    return Fraction(1, 2) if ($n   == 1);\n    return Fraction(0, 1) if ($n%2 == 1);\n\n    $cache->{$n} //= do {\n        (($n%6 == 4 ? Fraction(-1, 2) : 1) * Fraction($n+3, 3) -\n            (sum(map {\n                Number(binomial($n+3, $n - 6*$_)) * __SUB__->($n - 6*$_, $cache)\n            } 1 .. ($n - $n%6) / 6) // 0)\n        ) / Number(binomial($n+3, $n))\n    };\n}\n\nforeach my $n (1..15) {\n    say ramanujan_bernoulli_number(2*$n);\n}\n\n__END__\nFraction(5, 30)\nFraction(-7, 210)\nFraction(18, 756)\nFraction(-495, 14850)\nFraction(27300, 360360)\nFraction(-783594, 3095820)\nFraction(1060290000, 908820000)\nFraction(-3120392555280, 439977938400)\nFraction(1540021169559600, 28015065842400)\nFraction(-1138211737294401000000, 2151123774030000000)\nFraction(2845151832177208505952000000, 459479203757525952000000)\nFraction(-149443274714737339648102583520000, 1726066502932685055105600000)\nFraction(13609846707523944448974596493300000000000000, 9547304673537038744166600000000000000)\nFraction(-11263363110434888054130093206882749787055697920000000000, 412604138431303034312458421474352537600000000000)\nFraction(3343163067256114252216624560628967465552283801361747968000000000, 5557296138055536045317952219562393233733243699200000000)\n"
  },
  {
    "path": "Math/bernoulli_numbers_recursive.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 21 September 2015\n# Website: https://github.com/trizen\n\n# Recursive computation of Bernoulli numbers.\n\n# See: https://en.wikipedia.org/wiki/Bernoulli_number#Recursive_definition\n#      https://en.wikipedia.org/wiki/Binomial_coefficient#Recursive_formula\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Memoize qw(memoize);\nuse Math::AnyNum qw(:overload);\n\nno warnings qw(recursion);\n\nmemoize('binomial');\nmemoize('bern_helper');\nmemoize('bernoulli_number');\n\nsub binomial {\n    my ($n, $k) = @_;\n    $k == 0 || $n == $k ? 1 : binomial($n - 1, $k - 1) + binomial($n - 1, $k);\n}\n\nsub bern_helper {\n    my ($n, $k) = @_;\n    binomial($n, $k) * (bernoulli_number($k) / ($n - $k + 1));\n}\n\nsub bern_diff {\n    my ($n, $k, $d) = @_;\n    $n < $k ? $d : bern_diff($n, $k + 1, $d - bern_helper($n + 1, $k));\n}\n\nsub bernoulli_number {\n    my ($n) = @_;\n\n    return 1/2 if $n == 1;\n    return 0   if $n % 2;\n\n    $n > 0 ? bern_diff($n - 1, 0, 1) : 1;\n}\n\nfor my $i (0 .. 50) {\n    printf \"B%-3d = %s\\n\", 2 * $i, bernoulli_number(2 * $i);\n}\n"
  },
  {
    "path": "Math/bernoulli_numbers_recursive_2.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 04 October 2016\n# Website: https://github.com/trizen\n\n# Recursive computation of Bernoulli numbers (slightly improved).\n# https://en.wikipedia.org/wiki/Bernoulli_number#Recursive_definition\n\nuse 5.014;\nuse strict;\nuse warnings;\n\nuse Memoize qw(memoize);\nuse Math::AnyNum qw(:overload binomial);\n\nmemoize('bernoulli');\n\nsub bernoulli {\n    my ($n) = @_;\n\n    return 1/2 if $n == '1';\n    return   0 if $n  % '2';\n    return   1 if $n == '0';\n\n    my $bern = 1/2 - 1 / ($n + 1);\n    for (my $k = '2' ; $k < $n ; $k += '2') {\n        $bern -= bernoulli($k) * binomial($n, $k) / ($n - $k + '1');\n    }\n    $bern;\n}\n\nforeach my $i (0 .. 50) {\n    printf \"B%-3d = %s\\n\", '2' * $i, bernoulli('2' * $i);\n}\n"
  },
  {
    "path": "Math/bernoulli_numbers_seidel.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 06 October 2016\n# Website: https://github.com/trizen\n\n# Algorithm from:\n#   https://oeis.org/wiki/User:Peter_Luschny/ComputationAndAsymptoticsOfBernoulliNumbers#Seidel\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum;\n\nsub bernoulli_seidel {\n    my ($n) = @_;\n\n    $n == 0 and return Math::AnyNum->one;\n    $n == 1 and return Math::AnyNum->new('1/2');\n    $n % 2  and return Math::AnyNum->zero;\n\n    state $one = Math::GMPz::Rmpz_init_set_ui(1);\n\n    my @D = (\n             Math::GMPz::Rmpz_init_set_ui(0),\n             Math::GMPz::Rmpz_init_set_ui(1),\n             map { Math::GMPz::Rmpz_init_set_ui(0) } (1 .. $n / 2 - 1)\n            );\n\n    my ($h, $w) = (1, 1);\n    foreach my $i (0 .. $n - 1) {\n        if ($w ^= 1) {\n            Math::GMPz::Rmpz_add($D[$_], $D[$_], $D[$_ - 1]) for (1 .. $h - 1);\n        }\n        else {\n            $w = $h++;\n            Math::GMPz::Rmpz_add($D[$w], $D[$w], $D[$w + 1]) while --$w;\n        }\n    }\n\n    Math::AnyNum->new($D[$h - 1]) / Math::AnyNum->new((($one << ($n + 1)) - 2) * ($n % 4 == 0 ? -1 : 1));\n}\n\nforeach my $i (0 .. 50) {\n    printf \"B%-3d = %s\\n\", 2 * $i, bernoulli_seidel(2 * $i);\n}\n"
  },
  {
    "path": "Math/bi-unitary_divisors.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 13 September 2023\n# https://github.com/trizen\n\n# Generate the bi-unitary divisors of n.\n\n# See also:\n#   https://oeis.org/A188999\n#   https://oeis.org/A222266\n\nuse 5.036;\nuse ntheory qw(:all);\n\nsub gcud (@list) {  # greatest common unitary divisor\n\n    my $g = gcd(@list);\n\n    foreach my $n (@list) {\n        next if ($n == 0);\n        while (1) {\n            my $t = gcd($g, divint($n, $g));\n            last if ($t == 1);\n            $g = divint($g, $t);\n        }\n        last if ($g == 1);\n    }\n\n    return $g;\n}\n\nsub bi_unitary_divisors ($n) {\n\n    my @d = (1);\n\n    foreach my $pp (factor_exp($n)) {\n        my ($p, $e) = @$pp;\n\n        my @t;\n        my $r = 1;\n        foreach my $j (1 .. $e) {\n            $r = mulint($r, $p);\n            if (gcud($r, divint($n, $r)) == 1) {\n                push @t, map { mulint($r, $_) } @d;\n            }\n        }\n        push @d, @t;\n    }\n\n    return sort { $a <=> $b } @d;\n}\n\nforeach my $n (1 .. 20) {\n    my @biudivisors = bi_unitary_divisors($n);\n    say \"bi-udivisors of $n: [@biudivisors]\";\n}\n\n__END__\nbi-udivisors of 1: [1]\nbi-udivisors of 2: [1 2]\nbi-udivisors of 3: [1 3]\nbi-udivisors of 4: [1 4]\nbi-udivisors of 5: [1 5]\nbi-udivisors of 6: [1 2 3 6]\nbi-udivisors of 7: [1 7]\nbi-udivisors of 8: [1 2 4 8]\nbi-udivisors of 9: [1 9]\nbi-udivisors of 10: [1 2 5 10]\nbi-udivisors of 11: [1 11]\nbi-udivisors of 12: [1 3 4 12]\nbi-udivisors of 13: [1 13]\nbi-udivisors of 14: [1 2 7 14]\nbi-udivisors of 15: [1 3 5 15]\nbi-udivisors of 16: [1 2 8 16]\nbi-udivisors of 17: [1 17]\nbi-udivisors of 18: [1 2 9 18]\nbi-udivisors of 19: [1 19]\nbi-udivisors of 20: [1 4 5 20]\n"
  },
  {
    "path": "Math/binary_gcd_algorithm.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 12 August 2017\n# https://github.com/trizen\n\n# Algorithm invented by J. Stein in 1967, described in the\n# book \"Algorithmic Number Theory\" by Eric Bach and Jeffrey Shallit.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub binary_gcd {\n    my ($u, $v) = @_;\n\n    my $g = 1;\n\n    while (($u & 1) == 0 and ($v & 1) == 0) {\n        $u >>= 1;\n        $v >>= 1;\n        $g <<= 1;\n    }\n\n    while ($u != 0) {\n        if (($u & 1) == 0) {\n            $u >>= 1;\n        }\n        elsif (($v & 1) == 0) {\n            $v >>= 1;\n        }\n        elsif ($u >= $v) {\n            $u -= $v;\n            $u >>= 1;\n        }\n        else {\n            $v -= $u;\n            $v >>= 1;\n        }\n    }\n\n    return ($g * $v);\n}\n\nsay binary_gcd(10628640, 3628800);     #=> 1440\nsay binary_gcd(3628800,  10628640);    #=> 1440\n"
  },
  {
    "path": "Math/binary_gcd_algorithm_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 12 August 2017\n# https://github.com/trizen\n\n# Algorithm invented by J. Stein in 1967, described in the\n# book \"Algorithmic Number Theory\" by Eric Bach and Jeffrey Shallit.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\n\nsub binary_gcd {\n    my ($u, $v) = @_;\n\n    $u = Math::GMPz::Rmpz_init_set($u);\n    $v = Math::GMPz::Rmpz_init_set($v);\n\n    my $g = Math::GMPz::Rmpz_init_set_ui(1);\n\n    while (Math::GMPz::Rmpz_even_p($u) and Math::GMPz::Rmpz_even_p($v)) {\n        Math::GMPz::Rmpz_div_2exp($v, $v, 1);\n        Math::GMPz::Rmpz_div_2exp($u, $u, 1);\n        Math::GMPz::Rmpz_mul_2exp($g, $g, 1);\n    }\n\n    while (Math::GMPz::Rmpz_sgn($u)) {\n        if (Math::GMPz::Rmpz_even_p($u)) {\n            Math::GMPz::Rmpz_div_2exp($u, $u, 1);\n        }\n        elsif (Math::GMPz::Rmpz_even_p($v)) {\n            Math::GMPz::Rmpz_div_2exp($v, $v, 1);\n        }\n        elsif (Math::GMPz::Rmpz_cmp($u, $v) >= 0) {\n            Math::GMPz::Rmpz_sub($u, $u, $v);\n            Math::GMPz::Rmpz_div_2exp($u, $u, 1);\n        }\n        else {\n            Math::GMPz::Rmpz_sub($v, $v, $u);\n            Math::GMPz::Rmpz_div_2exp($v, $v, 1);\n        }\n    }\n\n    Math::GMPz::Rmpz_mul($g, $g, $v);\n    return $g;\n}\n\nmy $u = Math::GMPz->new('484118311800307409686872049018968526148964320406131317406564776592214983358038627898935326228550128722261905040875508300794183477624832000000000000000000000000');\nmy $v = Math::GMPz->new('93326215443944152681699238856266700490715968264381621468592963895217599993229915608941463976156518286253697920827223758251185210916864000000000000000000000000');\n\nsay binary_gcd($u, $v); #=> 33464469725118339932738475939854523519700805708105926500308251028510111778609255576238987149312000000000000000000000000\nsay binary_gcd($v, $u); #=> 33464469725118339932738475939854523519700805708105926500308251028510111778609255576238987149312000000000000000000000000\n"
  },
  {
    "path": "Math/binary_multiplier.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 07 August 2015\n# Website: https://github.com/trizen\n\n# A very simple binary multiplier.\n# Derived from: https://en.wikipedia.org/wiki/Binary_multiplier#A_more_advanced_approach:_an_unsigned_example\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nmy $a = 0b11110001;\nmy $b = 0b11011011;\n\nsay $a;\nsay $b;\nsay $a * $b;\n\nmy @a = reverse(split(//, sprintf(\"%b\", $a)));\n\nmy $p = 0;\nforeach my $i (@a) {\n    $i && ($p += $b);\n    $b <<= 1;\n}\n\nsay $p;\n"
  },
  {
    "path": "Math/binary_prime_encoder.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 22 September 2016\n# https://github.com/trizen\n\n# Encode prime numbers below a certain limit into a large number.\n\n# Example for primes below 7:\n#\n#   x = 110101\n#\n# where each (k+1)-th bit in x is 1 when (k+1) is prime.\n#\n# This can be illustrated as:\n#   [1, 1, 0, 1, 0, 1]\n#   [2, 3, 4, 5, 6, 7]\n#\n# The binary number 110101 is represented by 53 in base 10.\n\n# See also: https://oeis.org/A072762\n#           https://en.wikipedia.org/wiki/Prime_constant\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nno warnings 'recursion';\n\nuse Memoize qw(memoize);\nuse Math::AnyNum qw(:overload);\nuse ntheory qw(is_prime prev_prime);\n\nmemoize('_encode');\n\nsub _encode {\n    my ($n) = @_;\n    $n < 2 ? 0 : 2 * _encode($n - 1) + (is_prime($n) ? 1 : 0);\n}\n\nsub encode_primes {\n    my ($limit) = @_;\n    _encode(prev_prime($limit + 1));\n}\n\nsub decode_primes {\n    my ($n) = @_;\n\n    my $pow   = $n >> 1;\n    my $shift = 1;\n\n    while (($pow + 1) & $pow) {\n        $pow |= $pow >> $shift;\n        $shift <<= 1;\n    }\n\n    $pow += 1;\n\n    my @primes;\n    my $p = 2;\n\n    while ($pow) {\n        if ($n & $pow) {\n            push @primes, $p;\n        }\n        ++$p;\n        $pow >>= 1;\n    }\n\n    @primes;\n}\n\nsay \"Encoded primes below 100: \", encode_primes(100);\nsay \"Decoded primes below 100: \", join(' ', decode_primes(encode_primes(100)));\n\n__END__\nEncoded primes below 100: 65709066564613793476872782081\nDecoded primes below 100: 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97\n"
  },
  {
    "path": "Math/binary_prime_encoder_fast.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 22 September 2016\n# https://github.com/trizen\n\n# Encode the first n prime numbers into a large integer.\n\n# See also:\n#    https://oeis.org/A135482\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload);\nuse ntheory qw(nth_prime valuation);\n\nsub encode_primes {\n    my ($n) = @_;\n\n    my $sum = 0;\n    foreach my $i (1 .. $n) {\n        $sum |= 1 << nth_prime($i);\n    }\n\n    $sum >> 2;\n}\n\nsub decode_primes {\n    my ($n) = @_;\n\n    my $p = 2;\n    my @primes;\n\n    while ($n) {\n        if ($n & 1) {\n            push @primes, $p;\n        }\n\n        my $v = valuation($n, 2) || 1;\n        $n >>= $v;\n        $p += $v;\n    }\n\n    @primes;\n}\n\nsay \"Encoded first 25 primes: \", encode_primes(25);\nsay \"Decoded first 25 primes: \", join(' ', decode_primes(encode_primes(25)));\n\n__END__\nEncoded first 25 primes: 39771395718504928067455191595\nDecoded first 25 primes: 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97\n"
  },
  {
    "path": "Math/binary_prime_sieve_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 18 May 2017\n# https://github.com/trizen\n\n# A binary sieve for prime numbers.\n\n# Useful only when memory is very restricted.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\n\nsub binary_prime_sieve {\n    my ($n) = @_;\n\n    my $t = Math::GMPz::Rmpz_init_set_ui(1);\n    my $c = Math::GMPz::Rmpz_init_set_ui(1);\n\n    Math::GMPz::Rmpz_setbit($c, $n);\n\n    foreach my $i (2 .. sqrt($n)) {\n        Math::GMPz::Rmpz_mul_2exp($t, $t, $n - $i**2);\n\n        for (my $j = $i**2 ; $j <= $n ; $j += $i) {\n            Math::GMPz::Rmpz_ior($c, $c, $t);\n            Math::GMPz::Rmpz_div_2exp($t, $t, $i);\n        }\n\n        Math::GMPz::Rmpz_set_ui($t, 1);\n    }\n\n    my $bin = Math::GMPz::Rmpz_get_str($c, 2);\n\n    my @primes;\n    foreach my $p (2 .. $n) {\n        substr($bin, $p, 1) || push(@primes, $p);\n    }\n    return @primes;\n}\n\nmy $n = shift(@ARGV) // 100;\nmy @primes = binary_prime_sieve($n);\nsay join(' ', @primes);\nsay \"PI($n) = \", scalar(@primes);\n"
  },
  {
    "path": "Math/binary_splitting_product.pl",
    "content": "#!/usr/bin/perl\n\n# Compute the product of a list of numbers, using binary splitting.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Binary_splitting\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nsub binsplit_product ($s, $n, $m) {\n    $n > $m  and return 1;\n    $n == $m and return $s->[$n];\n    my $k = ($n + $m) >> 1;\n    __SUB__->($s, $n, $k) * __SUB__->($s, $k + 1, $m);\n}\n\nforeach my $n (1 .. 10) {\n    my @list = (1 .. $n);\n    printf \"%2d! = %s\\n\", $n, binsplit_product(\\@list, 0, $#list);\n}\n"
  },
  {
    "path": "Math/binomial_sum_with_imaginary_term.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 31 July 2017\n# Edit: 01 January 2018\n# https://github.com/trizen\n\n# Binomial summation in integers of an expression of the form: (a + b*sqrt(-1))^n\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload binomial);\n\nsub imaginary_binomial_sum {\n    my ($c, $d, $n) = @_;\n\n    my $re = 0;\n    my $im = 0;\n\n    foreach my $k (0 .. $n) {\n        my $t = binomial($n, $k) * $c**($n - $k) * $d**$k;\n\n        if ($k % 4 == 0) {\n            $re += $t;\n        }\n        elsif ($k % 4 == 1) {\n            $im += $t;\n        }\n        elsif ($k % 4 == 2) {\n            $re -= $t;\n        }\n        elsif ($k % 4 == 3) {\n            $im -= $t;\n        }\n    }\n\n    return ($re, $im);\n}\n\n#\n## Example for: (2 + 3*sqrt(-1))^10\n#\n\nmy $c = 2;\nmy $d = 3;\nmy $n = 10;\n\nmy ($re, $im) = imaginary_binomial_sum($c, $d, $n);\n\nsay \"($c + $d*sqrt(-1))^$n = ($re, $im)\";       #=> (-341525, -145668)\n"
  },
  {
    "path": "Math/binomial_theorem.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 19 December 2016\n# https://github.com/trizen\n\n# Implementation of the binomial theorem.\n\n# Defined as:\n#   (a + b)^n = sum(g(k) * a^(n-k) * b^k, {k=0, n})\n#\n# where g(k) is:\n#   g(0) = 1\n#   g(k) = (n - k + 1) * g(k-1) / k\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nno warnings 'recursion';\n\n#\n## The binomial coefficient: (n, k)\n#\nsub g {\n    my ($n, $k) = @_;\n    $k == 0 ? 1 : ($n - $k + 1) * g($n, $k - 1) / $k;\n}\n\n#\n## Binomial summation for (a + b)^n\n#\nsub binomial_sum {\n    my ($a, $b, $n) = @_;\n    my $sum = 0;\n    foreach my $k (0 .. $n) {\n        $sum += g($n, $k) * $a**($n - $k) * $b**$k;\n    }\n    return $sum;\n}\n\n#\n## Example for (1 + 1/30)^30\n#\n\nmy $a = 1;\nmy $b = 1/30;\nmy $n = 30;\n\nsay binomial_sum($a, $b, $n);       #=> 2.6743187758703\n"
  },
  {
    "path": "Math/bitstring_prime_sieve_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 09 July 2017\n# https://github.com/trizen\n\n# A decently fast bit-string sieve for prime numbers.\n# It's asymptotically faster than using Perl's arrays.\n\n# Also useful when memory is very restricted.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\n\nsub bitstring_prime_sieve {\n    my ($n) = @_;\n\n    my $c = Math::GMPz::Rmpz_init_set_ui(1);\n\n    Math::GMPz::Rmpz_setbit($c, $n + 1);\n\n    my $bound = int(sqrt($n));\n\n    for (my $i = 3 ; $i <= $bound ; $i += 2) {\n        if (!Math::GMPz::Rmpz_tstbit($c, $i)) {\n            for (my $j = $i * $i ; $j <= $n ; $j += $i << 1) {\n                Math::GMPz::Rmpz_setbit($c, $j);\n            }\n        }\n    }\n\n    my @primes = (2);\n    foreach my $k (1 .. ($n - 1) >> 1) {\n        Math::GMPz::Rmpz_tstbit($c, ($k << 1) + 1) || push(@primes, ($k << 1) + 1);\n    }\n    return @primes;\n}\n\nmy $n      = shift(@ARGV) // 100;\nmy @primes = bitstring_prime_sieve($n);\nsay join(' ', @primes);\nsay \"PI($n) = \", scalar(@primes);\n"
  },
  {
    "path": "Math/bitstring_prime_sieve_vec.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 14 May 2018\n# https://github.com/trizen\n\n# A decently fast bit-string sieve for prime numbers.\n\n# Useful when memory is very restricted.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub bitstring_prime_sieve {\n    my ($n) = @_;\n\n    my $c     = '';\n    my $bound = int(sqrt($n));\n\n    for (my $i = 3 ; $i <= $bound ; $i += 2) {\n        if (!vec($c, $i, 1)) {\n            for (my $j = $i * $i ; $j <= $n ; $j += $i << 1) {\n                vec($c, $j, 1) = 1;\n            }\n        }\n    }\n\n    my @primes = (2);\n    foreach my $k (1 .. ($n - 1) >> 1) {\n        vec($c, ($k << 1) + 1, 1) || push(@primes, ($k << 1) + 1);\n    }\n    return @primes;\n}\n\nmy $n      = shift(@ARGV) // 100;\nmy @primes = bitstring_prime_sieve($n);\nsay join(' ', @primes);\nsay \"PI($n) = \", scalar(@primes);\n"
  },
  {
    "path": "Math/both_truncatable_primes_in_base.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 12 January 2019\n# Edit: 28 March 2023\n# https://github.com/trizen\n\n# Generate the entire sequence of both-truncatable primes in a given base.\n\n# Optimization:\n#   there are far fewer right-truncatable primes than are left-truncatable primes,\n#   so we can generate only the RTPs and then check which ones are also LTPs.\n\n# Maximum value for each base is given in the following OEIS sequence:\n#   https://oeis.org/A323137\n\n# Total number of primes that are both left-truncatable and right-truncatable in base n:\n#   https://oeis.org/A323390\n\n# See also:\n#   https://www.youtube.com/watch?v=azL5ehbw_24\n#   https://en.wikipedia.org/wiki/Truncatable_prime\n\n# Related sequences:\n#  https://oeis.org/A076586 - Total number of right truncatable primes in base n.\n#  https://oeis.org/A076623 - Total number of left truncatable primes (without zeros) in base n.\n#  https://oeis.org/A323390 - Total number of primes that are both left-truncatable and right-truncatable in base n.\n#  https://oeis.org/A323396 - Irregular array read by rows, where T(n, k) is the k-th prime that is both left-truncatable and right-truncatable in base n.\n\nuse 5.036;\nuse ntheory                qw(primes vecmax is_prime);\nuse Math::Prime::Util::GMP qw(divint mulint addint subint);\n\nsub is_left_truncatable ($n, $base) {\n\n    for (my $r = $base ; $r < $n ; $r = mulint($r, $base)) {\n        is_prime(subint($n, mulint($r, divint($n, $r)))) || return 0;\n    }\n\n    return 1;\n}\n\nsub generate_from_prefix ($p, $base) {\n\n    my @seq = ($p);\n\n    foreach my $d (1 .. $base - 1) {\n        my $n = addint(mulint($p, $base), $d);\n        if (is_prime($n)) {\n            push @seq, grep { is_left_truncatable($_, $base) } generate_from_prefix($n, $base);\n        }\n    }\n\n    return @seq;\n}\n\nsub both_truncatable_primes_in_base ($base) {\n\n    return if $base <= 2;\n\n    my @truncatable;\n    foreach my $p (@{primes(2, $base - 1)}) {\n        push @truncatable, generate_from_prefix($p, $base);\n    }\n    return @truncatable;\n}\n\nforeach my $base (3 .. 36) {\n    my @t = both_truncatable_primes_in_base($base);\n    printf(\"There are %3d both-truncatable primes in base %2d where largest is %s\\n\", scalar(@t), $base, vecmax(@t));\n}\n\n__END__\nThere are    2 both-truncatable primes in base  3 where largest is 23\nThere are    3 both-truncatable primes in base  4 where largest is 11\nThere are    5 both-truncatable primes in base  5 where largest is 67\nThere are    9 both-truncatable primes in base  6 where largest is 839\nThere are    7 both-truncatable primes in base  7 where largest is 37\nThere are   22 both-truncatable primes in base  8 where largest is 1867\nThere are    8 both-truncatable primes in base  9 where largest is 173\nThere are   15 both-truncatable primes in base 10 where largest is 739397\nThere are    6 both-truncatable primes in base 11 where largest is 79\nThere are   35 both-truncatable primes in base 12 where largest is 105691\nThere are   11 both-truncatable primes in base 13 where largest is 379\nThere are   37 both-truncatable primes in base 14 where largest is 37573\nThere are   17 both-truncatable primes in base 15 where largest is 647\nThere are   22 both-truncatable primes in base 16 where largest is 3389\nThere are   12 both-truncatable primes in base 17 where largest is 631\nThere are   69 both-truncatable primes in base 18 where largest is 202715129\nThere are   12 both-truncatable primes in base 19 where largest is 211\nThere are   68 both-truncatable primes in base 20 where largest is 155863\nThere are   18 both-truncatable primes in base 21 where largest is 1283\nThere are   44 both-truncatable primes in base 22 where largest is 787817\nThere are   13 both-truncatable primes in base 23 where largest is 439\nThere are  145 both-truncatable primes in base 24 where largest is 109893629\nThere are   16 both-truncatable primes in base 25 where largest is 577\nThere are   47 both-truncatable primes in base 26 where largest is 4195880189\nThere are   20 both-truncatable primes in base 27 where largest is 1811\nThere are   77 both-truncatable primes in base 28 where largest is 14474071\nThere are   13 both-truncatable primes in base 29 where largest is 379\nThere are  291 both-truncatable primes in base 30 where largest is 21335388527\nThere are   15 both-truncatable primes in base 31 where largest is 2203\nThere are   89 both-truncatable primes in base 32 where largest is 1043557\nThere are   27 both-truncatable primes in base 33 where largest is 2939\nThere are   74 both-truncatable primes in base 34 where largest is 42741029\nThere are   20 both-truncatable primes in base 35 where largest is 2767\nThere are  241 both-truncatable primes in base 36 where largest is 50764713107\nThere are   18 both-truncatable primes in base 37 where largest is 853\nThere are  106 both-truncatable primes in base 38 where largest is 65467229\nThere are   25 both-truncatable primes in base 39 where largest is 4409\nThere are  134 both-truncatable primes in base 40 where largest is 8524002457\nThere are   15 both-truncatable primes in base 41 where largest is 113\nThere are  450 both-truncatable primes in base 42 where largest is 1272571820725769\nThere are   23 both-truncatable primes in base 43 where largest is 4861\nThere are  144 both-truncatable primes in base 44 where largest is 3215447359\nThere are   33 both-truncatable primes in base 45 where largest is 5897\nThere are  131 both-truncatable primes in base 46 where largest is 8542971469\nThere are   24 both-truncatable primes in base 47 where largest is 1741\nThere are  491 both-truncatable primes in base 48 where largest is 531866995189\nThere are   27 both-truncatable primes in base 49 where largest is 6421\nThere are  235 both-truncatable primes in base 50 where largest is 297897697\nThere are   29 both-truncatable primes in base 51 where largest is 2399\nThere are  187 both-truncatable primes in base 52 where largest is 2276097403\nThere are   23 both-truncatable primes in base 53 where largest is 2281\nThere are  575 both-truncatable primes in base 54 where largest is 586812834217\nThere are   30 both-truncatable primes in base 55 where largest is 7537\nThere are  218 both-truncatable primes in base 56 where largest is 3086112347\nThere are   31 both-truncatable primes in base 57 where largest is 9521\nThere are  183 both-truncatable primes in base 58 where largest is 24666304823\nThere are   25 both-truncatable primes in base 59 where largest is 9619\nThere are 1377 both-truncatable primes in base 60 where largest is 200416308070405393\nThere are   26 both-truncatable primes in base 61 where largest is 2503\nThere are  247 both-truncatable primes in base 62 where largest is 2467459748009\nThere are   37 both-truncatable primes in base 63 where largest is 10271\nThere are  231 both-truncatable primes in base 64 where largest is 1591175082967\n"
  },
  {
    "path": "Math/brazilian_primes_constant.pl",
    "content": "#!/usr/bin/perl\n\n# Compute the decimal expansion of the sum of reciprocals of Brazilian primes, also called the Brazilian primes constant.\n\n# The constant begins as:\n#   0.3317544666\n\n# OEIS sequences:\n#   https://oeis.org/A085104 (Brazillian primes)\n#   https://oeis.org/A306759 (Decimal expansion of the sum of reciprocals of Brazilian primes)\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse ntheory qw(:all);\nuse Math::AnyNum;\n\nsub brazillian_constant ($lim) {\n\n    my $N = Math::GMPz->new(\"$lim\");\n    my $q = Math::GMPq->new(0);\n    my $z = Math::GMPz->new(0);\n\n    my $sum = Math::MPFR::Rmpfr_init2(192);\n    Math::MPFR::Rmpfr_set_ui($sum, 0, 0);\n\n    my %seen;\n\n    # The algorithm for generating the Brazillian primes is due to M. F. Hasler.\n    # See: https://oeis.org/A085104\n\n    forprimes {\n        my $K = $_;\n        for my $n (2 .. rootint($N - 1, $K - 1)) {\n\n            Math::GMPz::Rmpz_ui_pow_ui($z, $n, $K);\n            Math::GMPz::Rmpz_sub_ui($z, $z, 1);\n            Math::GMPz::Rmpz_divexact_ui($z, $z, $n - 1);\n\n            if (\n                is_prob_prime(\n                                Math::GMPz::Rmpz_fits_ulong_p($z)\n                              ? Math::GMPz::Rmpz_get_ui($z)\n                              : Math::GMPz::Rmpz_get_str($z, 10)\n                             )\n              ) {\n\n                # Conjecture: duplicate terms may happen only for t = 2^k-1, for some k\n                if ((($z + 1) & $z) == 0) {\n                    next if $seen{$z}++;\n                }\n\n                if ($z < $N) {\n                    Math::GMPq::Rmpq_set_ui($q, 1, 1);\n                    Math::GMPq::Rmpq_set_den($q, $z);\n                    Math::MPFR::Rmpfr_add_q($sum, $sum, $q, 0);\n                }\n            }\n        }\n    } 3, logint($N + 1, 2);\n\n    return Math::AnyNum->new($sum);\n}\n\nforeach my $n (1 .. 14) {\n    say \"B(10^$n) ~ \", brazillian_constant(Math::GMPz->new(10)**$n)->round(-32);\n}\n\n__END__\nB(10^1)  ~ 0.14285714285714285714285714285714\nB(10^2)  ~ 0.28899272838682348594073100542184\nB(10^3)  ~ 0.32290223556269144810843769843366\nB(10^4)  ~ 0.32952368063536693571523726793301\nB(10^5)  ~ 0.33121713119461798438057432911381\nB(10^6)  ~ 0.33160386963492172892306297309503\nB(10^7)  ~ 0.33171391586547473334091623260371\nB(10^8)  ~ 0.33174341910781704122196304798802\nB(10^9)  ~ 0.33175132673949885380067237840723\nB(10^10) ~ 0.33175356516689372562521462231951\nB(10^11) ~ 0.33175420579318423292974799113059\nB(10^12) ~ 0.33175439067722742680152185017303\nB(10^13) ~ 0.33175444440331880514669754839817\nB(10^14) ~ 0.33175446011369675270545267094599\nB(10^15) ~ 0.33175446473544852087966767749508\nB(10^16) ~ 0.33175446610148680800864203095541  -- took 1 minute\nB(10^17) ~ 0.33175446650734519516960634448563  -- took 4 minutes\nB(10^18) ~ 0.33175446662828756863723305575693  -- took 20 minutes\nB(10^19) ~ 0.33175446666446018177571079766533  -- took 39 minutes\nB(10^20) ~ 0.33175446667530957668020208565143  -- took 5 hours and 23 minutes\n"
  },
  {
    "path": "Math/brown_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# See: https://www.youtube.com/watch?v=-Djj6pfR9KU\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(factorial is_power);\n\nfor my $i (1 .. 60) {\n    my $n = factorial($i) + 1;\n    is_power($n) || next;\n    printf(\"(%d, %d)\\n\", int(sqrt($n)), $i);\n}\n\n__END__\n(5, 4)\n(11, 5)\n(71, 7)\n"
  },
  {
    "path": "Math/carmichael_factorization_method.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 17 March 2019\n# https://github.com/trizen\n\n# A new factorization method for numbers with exactly three distinct prime factors of the form:\n#\n#   n = a * (a+x) * (a+y)\n#   n = a * ((a±1)*x ± 1) *  ((a±1)*y ± 1)\n#\n# for x,y relatively small.\n\n# Many Carmichael numbers and Lucas pseudoprimes are of this form and can be factorized relatively fast by this method.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Cubic_function\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(lastfor forcomb);\nuse Math::AnyNum qw(:overload isqrt icbrt round gcd);\n\n#<<<\nsub solve_cubic_equation ($a, $b, $c, $d) {\n\n    my $p = (3*$a*$c - $b*$b) / (3*$a*$a);\n    my $q = (2 * $b**3 - 9*$a*$b*$c + 27*$a*$a*$d) / (27 * $a**3);\n\n    my $t = (icbrt(-($q/2) + isqrt(($q**2 / 4) + ($p**3 / 27))) +\n             icbrt(-($q/2) - isqrt(($q**2 / 4) + ($p**3 / 27))));\n\n    my $x = round($t - $b/(3*$a));\n\n    return $x;\n}\n#>>>\n\nsub carmichael_factorization ($n, $l = 2, $h = 23) {\n\n    my $factor = 1;\n\n    my sub try_parameters ($a, $b, $c) {\n\n        my $t = solve_cubic_equation($a, $b, $c, -$n);\n        my $g = gcd($t, $n);\n\n        if ($g > 1 and $g < $n) {\n            $factor = $g;\n            return 1;\n        }\n    }\n\n    my @range = ($l .. $h);\n\n    forcomb {\n        my ($x, $y) = @range[@_];\n\n        my $a = $x * $y;\n        my $b = 2 * $a - $x - $y;\n        my $c = $a - $x - $y + 1;\n\n        try_parameters($a, $b,      $c)  and do { lastfor, return $factor };\n        try_parameters($a, -$b,     $c)  and do { lastfor, return $factor };\n        try_parameters(1,  $x + $y, $a)  and do { lastfor, return $factor };\n        try_parameters($a, $y - $x, -$c) and do { lastfor, return $factor };\n\n        try_parameters($a, (+2 * $y + 1) * $x + $y, ($y + 1) * $x + ($y + 1)) and do { lastfor, return $factor };\n        try_parameters($a, (-2 * $y - 1) * $x - $y, ($y + 1) * $x + ($y + 1)) and do { lastfor, return $factor };\n    } scalar(@range), 2;\n\n    return $factor;\n}\n\nsay carmichael_factorization(7520940423059310542039581);                                          #=> 79443853\nsay carmichael_factorization(1000000032900000272110000405099);                                    #=> 10000000103\nsay carmichael_factorization(570115866940668362539466801338334994649);                            #=> 4563211789627\nsay carmichael_factorization(8325544586081174440728309072452661246289);                           #=> 11153738721817\nsay carmichael_factorization(1169586052690021349455126348204184925097724507);                     #=> 166585508879747\nsay carmichael_factorization(61881629277526932459093227009982733523969186747);                    #=> 1233150073853267\nsay carmichael_factorization(173315617708997561998574166143524347111328490824959334367069087);    #=> 173823271649325368927\n"
  },
  {
    "path": "Math/carmichael_factorization_method_generalized.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 08 May 2019\n# https://github.com/trizen\n\n# A simple factorization method, using the binary search algorithm, for numbers of the form:\n#\n#   n = x * Prod_{k=1..r} ((x±1)*a_k ± 1)\n#\n# for `r` relatively small.\n\n# Many Carmichael numbers and Lucas pseudoprimes are of this form and can be factorized relatively fast by this method.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Binary_search_algorithm\n\nuse 5.024;\nuse warnings;\nuse experimental qw(signatures);\nuse ntheory qw(lastfor forcomb);\nuse Math::AnyNum qw(:overload bsearch_le iroot prod gcd);\n\nsub carmichael_factorization ($n, $k = 3, $l = 2, $h = 6) {\n\n    my @blocks = (\n        sub ($x, @params) {\n            map { ($x - 1) * $_ + 1 } @params;\n        },\n        sub ($x, @params) {\n            map { ($x + 1) * $_ - 1 } @params;\n        },\n    );\n\n    my @factors;\n    my @range = ($l .. $h);\n\n    forcomb {\n        my @params = @range[@_];\n\n        foreach my $block (@blocks) {\n\n            my $r = bsearch_le(\n                iroot($n, $k),\n                sub ($x) {\n                    (prod($block->($x, @params)) * $x) <=> $n;\n                }\n            );\n\n            my $g = gcd($r, $n);\n\n            if ($g > 1) {\n                @factors = grep { $n % $_ == 0 } ($r, $block->($r, @params));\n                @factors = ($g) if !@factors;\n                lastfor, return @factors;\n            }\n        }\n    } scalar(@range), $k - 1;\n\n    return @factors;\n}\n\n#<<<\nlocal $, = \", \";\n\nsay carmichael_factorization(7520940423059310542039581,                3);    #=> 79443853\nsay carmichael_factorization(570115866940668362539466801338334994649,  3);    #=> 4563211789627\nsay carmichael_factorization(8325544586081174440728309072452661246289, 3);    #=> 11153738721817\n\nsay '=' x 80;\n\nsay carmichael_factorization(60711773123792542753,                           4, 2,  10);    #=> 2597294701\nsay carmichael_factorization(73410179782535364796052059,                     2, 2,  18);    #=> 2141993519227\nsay carmichael_factorization(12946744736260953126701495197312513,            4, 2,  6);     #=> 37927921157953921\n\nsay '=' x 80;\n\nsay carmichael_factorization(1169586052690021349455126348204184925097724507,                  3, 11, 23);  #=> 166585508879747\nsay carmichael_factorization(61881629277526932459093227009982733523969186747,                 3, 3,  11);  #=> 1233150073853267\nsay carmichael_factorization(173315617708997561998574166143524347111328490824959334367069087, 3, 3,  11);  #=> 173823271649325368927\n\nsay '=' x 80;\n\n# Works even with larger numbers\nsay carmichael_factorization(89279013890805987845789287109721287627454944588023686038653206281186298337098760877273881);                                      #=> 245960883729518060519840003581\nsay carmichael_factorization(131754870930495356465893439278330079857810087607720627102926770417203664110488210785830750894645370240615968198960237761, 4);    #=> 245960883729518060519840003581\n#>>>\n"
  },
  {
    "path": "Math/carmichael_numbers_from_multiple.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 17 March 2023\n# https://github.com/trizen\n\n# Generate Carmichael numbers from a given multiple.\n\n# See also:\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory qw(:all);\n\nsub carmichael_from_multiple ($m, $callback) {\n\n    my $L = lcm(map { subint($_, 1) } factor($m));\n    my $v = invmod($m, $L) // return;\n\n    for (my $p = $v ; ; $p += $L) {\n\n        gcd($m, $p) == 1 or next;\n\n        my @factors = factor_exp($p);\n        (vecall { $_->[1] == 1 } @factors) || next;\n\n        my $n = $m * $p;\n        my $l = lcm(map { subint($_->[0], 1) } @factors);\n\n        if (($n - 1) % $l == 0) {\n            $callback->($n);\n        }\n    }\n}\n\ncarmichael_from_multiple(13 * 19, sub ($n) { say $n });\n"
  },
  {
    "path": "Math/carmichael_numbers_from_multiple_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 17 March 2023\n# https://github.com/trizen\n\n# Generate Carmichael numbers from a given multiple.\n\n# See also:\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory qw(:all);\n\nsub carmichael_from_multiple ($m, $callback) {\n\n    my $t = Math::GMPz::Rmpz_init();\n    my $u = Math::GMPz::Rmpz_init();\n    my $v = Math::GMPz::Rmpz_init();\n\n    is_square_free($m) || return;\n\n    my $L = lcm(map { subint($_, 1) } factor($m));\n\n    $m = Math::GMPz->new(\"$m\");\n    $L = Math::GMPz->new(\"$L\");\n\n    Math::GMPz::Rmpz_invert($v, $m, $L) || return;\n\n    for (my $p = Math::GMPz::Rmpz_init_set($v) ; ; Math::GMPz::Rmpz_add($p, $p, $L)) {\n\n        Math::GMPz::Rmpz_gcd($t, $m, $p);\n        Math::GMPz::Rmpz_cmp_ui($t, 1) == 0 or next;\n\n        my @factors = factor_exp($p);\n        (vecall { $_->[1] == 1 } @factors) || next;\n\n        Math::GMPz::Rmpz_mul($v, $m, $p);\n        Math::GMPz::Rmpz_sub_ui($u, $v, 1);\n\n        Math::GMPz::Rmpz_set_str($t, lcm(map { subint($_->[0], 1) } @factors), 10);\n\n        if (Math::GMPz::Rmpz_divisible_p($u, $t)) {\n            $callback->(Math::GMPz::Rmpz_init_set($v));\n        }\n    }\n}\n\ncarmichael_from_multiple(13 * 19, sub ($n) { say $n });\n"
  },
  {
    "path": "Math/carmichael_numbers_from_multiple_recursive_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 17 March 2023\n# https://github.com/trizen\n\n# Generate Carmichael numbers from a given multiple.\n\n# See also:\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory qw(:all);\n\nsub carmichael_from_multiple ($m, $callback, $reps = 1e4) {\n\n    my $t = Math::GMPz::Rmpz_init();\n    my $u = Math::GMPz::Rmpz_init();\n    my $v = Math::GMPz::Rmpz_init();\n\n    is_square_free($m) || return;\n\n    my $L = lcm(map { subint($_, 1) } factor($m));\n\n    $m = Math::GMPz->new(\"$m\");\n    $L = Math::GMPz->new(\"$L\");\n\n    Math::GMPz::Rmpz_invert($v, $m, $L) || return;\n\n    for (my $p = Math::GMPz::Rmpz_init_set($v) ; --$reps >= 0 ; Math::GMPz::Rmpz_add($p, $p, $L)) {\n\n        Math::GMPz::Rmpz_gcd($t, $m, $p);\n        Math::GMPz::Rmpz_cmp_ui($t, 1) == 0 or next;\n\n        my @factors = factor_exp($p);\n        (vecall { $_->[1] == 1 } @factors) || next;\n\n        Math::GMPz::Rmpz_mul($v, $m, $p);\n        Math::GMPz::Rmpz_sub_ui($u, $v, 1);\n\n        Math::GMPz::Rmpz_set_str($t, lcm(map { subint($_->[0], 1) } @factors), 10);\n\n        if (Math::GMPz::Rmpz_divisible_p($u, $t)) {\n            $callback->(Math::GMPz::Rmpz_init_set($v));\n        }\n    }\n}\n\nmy @list = (vecprod(5, 7, 13, 17, 19, 23));\n\nwhile (@list) {\n    my $m = shift(@list);\n    carmichael_from_multiple(\n        $m,\n        sub ($n) {\n            say $n;\n            push @list, $n;\n        }\n    );\n}\n"
  },
  {
    "path": "Math/carmichael_numbers_generation_erdos_method.pl",
    "content": "#!/usr/bin/perl\n\n# Erdos construction method for Carmichael numbers:\n#   1. Choose an even integer L with many prime factors.\n#   2. Let P be the set of primes d+1, where d|L and d+1 does not divide L.\n#   3. Find a subset S of P such that prod(S) == 1 (mod L). Then prod(S) is a Carmichael number.\n\n# Alternatively:\n#   3. Find a subset S of P such that prod(S) == prod(P) (mod L). Then prod(P) / prod(S) is a Carmichael number.\n\nuse 5.020;\nuse warnings;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\n# Modular product of a list of integers\nsub vecprodmod ($arr, $mod) {\n    my $prod = 1;\n    foreach my $k (@$arr) {\n        $prod = mulmod($prod, $k, $mod);\n    }\n    $prod;\n}\n\n# Primes p such that p-1 divides L and p does not divide L\nsub lambda_primes ($L) {\n    grep { $L % $_ != 0 } grep { $_ > 2 and is_prime($_) } map { $_ + 1 } divisors($L);\n}\n\nsub method_1 ($L) {     # smallest numbers first\n\n    my @P = lambda_primes($L);\n\n    foreach my $k (3 .. @P) {\n        forcomb {\n            if (vecprodmod([@P[@_]], $L) == 1) {\n                say vecprod(@P[@_]);\n            }\n        } scalar(@P), $k;\n    }\n}\n\nsub method_2 ($L) {     # largest numbers first\n\n    my @P = lambda_primes($L);\n    my $B = vecprodmod(\\@P, $L);\n    my $T = vecprod(@P);\n\n    foreach my $k (1 .. (@P-3)) {\n        forcomb {\n            if (vecprodmod([@P[@_]], $L) == $B) {\n                my $S = vecprod(@P[@_]);\n                say ($T / $S) if ($T != $S);\n            }\n        } scalar(@P), $k;\n    }\n}\n\nmethod_1(720);\nmethod_2(720);\n\n__END__\n15841\n115921\n488881\n41041\n172081\n5310721\n12262321\n16778881\n18162001\n76595761\n609865201\n133205761\n561777121\n1836304561\n832060801\n1932608161\n20064165121\n84127131361\n354725143201\n1487328704641\n3305455474321\n1945024664401\n2110112460001\n8879057210881\n65121765643441\n30614445878401\n"
  },
  {
    "path": "Math/carmichael_numbers_generation_erdos_method_dynamic_programming.pl",
    "content": "#!/usr/bin/perl\n\n# Erdos construction method for Carmichael numbers:\n#   1. Choose an even integer L with many prime factors.\n#   2. Let P be the set of primes d+1, where d|L and d+1 does not divide L.\n#   3. Find a subset S of P such that prod(S) == 1 (mod L). Then prod(S) is a Carmichael number.\n\n# Alternatively:\n#   3. Find a subset S of P such that prod(S) == prod(P) (mod L). Then prod(P) / prod(S) is a Carmichael number.\n\nuse 5.036;\nuse Math::GMPz qw();\nuse ntheory    qw(:all);\n\n# Primes p such that p-1 divides L and p does not divide L\nsub lambda_primes ($L) {\n    grep { $_ > 2 and $L % $_ != 0 and is_prime($_) } map { $_ + 1 } divisors($L);\n}\n\nsub method_1 ($L, $callback) {    # smallest numbers first\n\n    my @P = lambda_primes($L);\n    my @d = (Math::GMPz->new(1));\n\n    foreach my $p (@P) {\n\n        my @t;\n        foreach my $u (@d) {\n            my $t = $u * $p;\n            push(@t, $t);\n            if ($t % $L == 1) {\n                $callback->($t);\n            }\n        }\n\n        push @d, @t;\n    }\n\n    return;\n}\n\nsub method_2 ($L, $callback) {    # largest numbers first\n\n    my @P = lambda_primes($L);\n    my @d = (Math::GMPz->new(1));\n\n    my $T = Math::GMPz->new(vecprod(@P));\n    my $s = $T % $L;\n\n    foreach my $p (@P) {\n\n        my @t;\n        foreach my $u (@d) {\n            my $t = $u * $p;\n            push(@t, $t);\n            if ($t % $L == $s) {\n                $callback->($T / $t) if ($T != $t);\n            }\n        }\n\n        push @d, @t;\n    }\n\n    return;\n}\n\nmethod_1(720, sub ($c) { say $c });\nmethod_2(720, sub ($c) { say $c });\n\n__END__\n41041\n172081\n15841\n16778881\n832060801\n5310721\n76595761\n488881\n20064165121\n84127131361\n561777121\n18162001\n115921\n1932608161\n133205761\n1836304561\n12262321\n30614445878401\n2110112460001\n609865201\n1945024664401\n8879057210881\n354725143201\n3305455474321\n1487328704641\n65121765643441\n"
  },
  {
    "path": "Math/carmichael_numbers_in_range.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 27 August 2022\n# Edit: 09 March 2026\n# https://github.com/trizen\n\n# Generate all the Carmichael numbers with n prime factors in a given range [a,b].\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\n# PARI/GP program (in range) (simple):\n#   carmichael(A, B, k) = A=max(A, vecprod(primes(k+1))\\2); (f(m, l, lo, k) = my(list=List()); my(hi=sqrtnint(B\\m, k)); if(k==1, forprime(p=max(lo, ceil(A/m)), hi, my(t=m*p); if((t-1)%l == 0 && (t-1)%(p-1) == 0, listput(list, t))), forprime(p = lo, hi, my(t = m*p); my(L=lcm(l, p-1)); if(gcd(L, t) == 1, list=concat(list, f(t, L, p+1, k-1))))); list); vecsort(Vec(f(1, 1, 3, k)));\n\n# PARI/GP program (in range) (fast):\n#   carmichael(A, B, k) = A=max(A, vecprod(primes(k+1))\\2); my(max_p=(1+sqrtint(8*B+1))\\4); (f(m, l, lo, k) = my(list=List()); my(hi=min(max_p, sqrtnint(B\\m, k))); if(lo > hi, return(list)); if(k==1, lo=max(lo, ceil(A/m)); my(t=lift(1/Mod(m,l))); while(t < lo, t += l); forstep(p=t, hi, l, if(isprime(p), my(n=m*p); if((n-1)%(p-1) == 0, listput(list, n)))), forprime(p=lo, hi, if(gcd(m, p-1) == 1, list=concat(list, f(m*p, lcm(l, p-1), p+1, k-1))))); list); vecsort(Vec(f(1, 1, 3, k)));\n\n# PARI/GP program to generate all the Carmichael numbers <= n (fast):\n#   carmichael(A, B, k) = A=max(A, vecprod(primes(k+1))\\2); my(max_p=(1+sqrtint(8*B+1))\\4); (f(m, l, lo, k) = my(list=List()); my(hi=min(max_p, sqrtnint(B\\m, k))); if(lo > hi, return(list)); if(k==1, lo=max(lo, ceil(A/m)); my(t=lift(1/Mod(m,l))); while(t < lo, t += l); forstep(p=t, hi, l, if(isprime(p), my(n=m*p); if((n-1)%(p-1) == 0, listput(list, n)))), forprime(p=lo, hi, if(gcd(m, p-1) == 1, list=concat(list, f(m*p, lcm(l, p-1), p+1, k-1))))); list); f(1, 1, 3, k);\n#   upto(n) = my(list=List()); for(k=3, oo, if(vecprod(primes(k+1))\\2 > n, break); list=concat(list, carmichael(1, n, k))); vecsort(Vec(list));\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\n\nsub carmichael_numbers_in_range ($A, $B, $k) {\n\n    $A = vecmax($A, pn_primorial($k + 1) >> 1);\n\n    # Largest possisble prime factor for Carmichael numbers <= B\n    my $max_p = (1 + sqrtint(8 * $B + 1)) >> 2;\n\n    my @list;\n\n    sub ($m, $L, $lo, $k) {\n\n        my $hi = rootint(divint($B, $m), $k);\n\n        $lo > $hi && return;\n\n        # Pinch's bound for the second to last prime\n        if ($k == 2 and $m < 1_000) {\n            my $bound = 2 * $m * $m - 3 * $m + 2;\n            if ($hi > $bound) {\n                $hi = $bound;\n                $lo > $hi && return;\n            }\n        }\n\n        if ($k == 1) {\n\n            $hi = $m     if ($m < $hi);       # the last prime p_k must be <= m\n            $hi = $max_p if ($max_p < $hi);\n            $lo = vecmax($lo, cdivint($A, $m));\n            $lo > $hi && return;\n\n            my $inv_m = invmod($m, $L);\n            $inv_m > $hi && return;\n\n            my $t = $inv_m;\n            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);\n            $t > $hi && return;\n\n            if (divint($hi - $t, $L) < 1_000) {\n\n                # Approach 1: Fast linear scan for small search spaces\n                for (my $p = $t ; $p <= $hi ; $p += $L) {\n                    if (($m * $p - 1) % ($p - 1) == 0 and is_prime($p)) {\n                        push @list, $m * $p;\n                    }\n                }\n            }\n            else {\n                # Approach 2: Combinatorial divisor extraction for large spaces\n                foreach my $d (divisors($m - 1, $hi)) {\n                    my $p = $d + 1;\n\n                    next if $p < $lo;\n                    last if $p > $hi;\n\n                    # Only check the congruence and primality\n                    if ($p % $L == $inv_m and is_prime($p)) {\n                        push @list, $m * $p;\n                    }\n                }\n            }\n\n            return;\n        }\n\n        foreach my $p (@{primes($lo, $hi)}) {\n            if (gcd($m, $p >> 1) == 1) {\n                __SUB__->($m * $p, lcm($L, $p - 1), $p + 1, $k - 1);\n            }\n        }\n      }\n      ->(1, 1, 3, $k);\n\n    return sort { $a <=> $b } @list;\n}\n\nmy $from = 1;\nmy $upto = powint(10, 10);\n\nforeach my $k (3 .. 7) {\n    my @arr = carmichael_numbers_in_range($from, $upto, $k);\n    say \"There are: \", scalar(@arr), \" Carmichael numbers <= $upto with $k prime factors\";\n}\n\n__END__\nThere are: 335 Carmichael numbers <= 10000000000 with 3 prime factors\nThere are: 619 Carmichael numbers <= 10000000000 with 4 prime factors\nThere are: 492 Carmichael numbers <= 10000000000 with 5 prime factors\nThere are: 99 Carmichael numbers <= 10000000000 with 6 prime factors\nThere are: 2 Carmichael numbers <= 10000000000 with 7 prime factors\n"
  },
  {
    "path": "Math/carmichael_numbers_in_range_from_prime_factors.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 25 September 2022\n# https://github.com/trizen\n\n# Generate all the Carmichael numbers with n prime factors in a given range [A,B], using a given list of prime factors. (not in sorted order)\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory 0.74 qw(:all);\n\nsub carmichael_numbers_in_range ($A, $B, $k, $primes, $callback) {\n\n    $A = vecmax($A, pn_primorial($k));\n\n    # Largest possisble prime factor for Carmichael numbers <= B\n    my $max_p = (1 + sqrtint(8 * $B + 1)) >> 2;\n\n    my @P   = sort { $a <=> $b } grep { $_ <= $max_p } vecuniq(@$primes);\n    my $end = $#P;\n\n    sub ($m, $lambda, $j, $k) {\n\n        my $y = vecmin($max_p, rootint(divint($B, $m), $k));\n\n        if ($k == 1) {\n\n            my $x = cdivint($A, $m);\n\n            if ($P[-1] < $x) {\n                return;\n            }\n\n            foreach my $i ($j .. $end) {\n                my $p = $P[$i];\n\n                last if ($p > $y);\n                next if ($p < $x);\n\n                my $t = $m * $p;\n\n                if (($t - 1) % $lambda == 0 and ($t - 1) % ($p - 1) == 0) {\n                    $callback->($t);\n                }\n            }\n\n            return;\n        }\n\n        foreach my $i ($j .. $end) {\n            my $p = $P[$i];\n            last if ($p > $y);\n\n            gcd($m, $p - 1) == 1 or next;\n\n            # gcd($m*$p, euler_phi($m*$p)) == 1 or die \"$m*$p: not cyclic\";\n\n            __SUB__->($m * $p, lcm($lambda, $p - 1), $i + 1, $k - 1);\n        }\n      }\n      ->(1, 1, 0, $k);\n}\n\nmy $lambda = 5040;\nmy @primes = grep { $_ > 2 and $lambda % $_ != 0 and is_prime($_) } map { $_ + 1 } divisors($lambda);\n\nforeach my $k (3 .. 6) {\n    my @arr;\n    carmichael_numbers_in_range(1, 10**(2 * $k), $k, \\@primes, sub ($n) { push @arr, $n });\n    say \"$k: \", join(', ', sort { $a <=> $b } @arr);\n}\n\n__END__\n3: 29341, 115921, 399001, 488881\n4: 75361, 552721, 852841, 1569457, 3146221, 5310721, 8927101, 12262321, 27402481, 29020321, 49333201, 80282161\n5: 10877581, 18162001, 67994641, 75151441, 76595761, 129255841, 133205761, 140241361, 169570801, 311388337, 461854261, 548871961, 561777121, 568227241, 577240273, 609865201, 631071001, 765245881, 839275921, 1583582113, 2178944461, 2443829641, 2811315361, 3240392401, 3245477761, 3246238801, 3630291841, 4684846321, 4885398001, 5961977281, 6030849889, 7261390081, 7906474801, 9722094481, 9825933601\n6: 496050841, 832060801, 868234081, 1256855041, 1676641681, 1698623641, 1705470481, 1932608161, 2029554241, 2111416021, 3722793481, 4579461601, 5507520481, 5990940901, 7192589041, 7368233041, 8221139641, 13907587681, 16596266401, 19167739921, 22374999361, 23796818641, 29397916801, 33643718641, 41778063601, 42108575041, 47090317681, 48537130321, 53365160521, 54173581561, 57627937081, 57840264721, 60769467361, 66940720561, 74382893761, 74513421361, 77005913041, 77494371361, 84552825841, 88968511801, 94267516561, 97894836481, 107729884081, 112180797121, 114659813521, 126110113921, 126631194481, 131056332121, 142101232561, 152222039761, 167836660321, 169456971601, 171414489961, 174294847441, 187443219601, 193051454401, 207928264321, 225607349521, 237902646241, 244357656481, 297973194121, 314190832033, 329236460281, 330090228721, 335330503201, 494544949921, 507455393761, 582435435457, 638204086801, 639883767601, 643919472001, 672941621521, 725104658881, 810976375441, 866981525761\n"
  },
  {
    "path": "Math/carmichael_numbers_in_range_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 22 February 2023\n# Edit: 09 March 2026\n# https://github.com/trizen\n\n# Generate all the Carmichael numbers with n prime factors in a given range [a,b].\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\n# PARI/GP program (in range) (simple):\n#   carmichael(A, B, k) = A=max(A, vecprod(primes(k+1))\\2); (f(m, l, lo, k) = my(list=List()); my(hi=sqrtnint(B\\m, k)); if(k==1, forprime(p=max(lo, ceil(A/m)), hi, my(t=m*p); if((t-1)%l == 0 && (t-1)%(p-1) == 0, listput(list, t))), forprime(p = lo, hi, my(t = m*p); my(L=lcm(l, p-1)); if(gcd(L, t) == 1, list=concat(list, f(t, L, p+1, k-1))))); list); vecsort(Vec(f(1, 1, 3, k)));\n\n# PARI/GP program (in range) (faster):\n#   carmichael(A, B, k) = A=max(A, vecprod(primes(k+1))\\2); local f; (f = (m, l, lo, k) -> my(list=List()); my(hi=sqrtnint(B\\m, k)); if(lo > hi, return(list)); if(k==1, lo=max(lo, ceil(A/m)); my(t=lift(1/Mod(m,l))); while(t < lo, t += l); forstep(p=t, hi, l, if((m*p-1)%(p-1) == 0 && isprime(p), listput(list, m*p))), forprime(p=lo, hi, if(gcd(m, p-1) == 1, list=concat(list, f(m*p, lcm(l, p-1), p+1, k-1))))); list); vecsort(Vec(f(1, 1, 3, k)));\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory 0.74 qw(:all);\n\nsub carmichael_numbers_in_range ($A, $B, $k) {\n\n    $A = vecmax($A, pn_primorial($k + 1) >> 1);\n\n    $A = Math::GMPz->new(\"$A\");\n    $B = Math::GMPz->new(\"$B\");\n\n    my $u = Math::GMPz::Rmpz_init();\n    my $v = Math::GMPz::Rmpz_init();\n\n    # max_p = floor((1 + sqrt(8*B + 1))/4)\n    my $max_p = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_mul_2exp($max_p, $B, 3);\n    Math::GMPz::Rmpz_add_ui($max_p, $max_p, 1);\n    Math::GMPz::Rmpz_sqrt($max_p, $max_p);\n    Math::GMPz::Rmpz_add_ui($max_p, $max_p, 1);\n    Math::GMPz::Rmpz_div_2exp($max_p, $max_p, 2);\n    $max_p = Math::GMPz::Rmpz_get_ui($max_p) if Math::GMPz::Rmpz_fits_ulong_p($max_p);\n\n    my @list;\n\n    sub ($m, $L, $lo, $k) {\n\n        Math::GMPz::Rmpz_tdiv_q($u, $B, $m);\n        Math::GMPz::Rmpz_root($u, $u, $k);\n\n        Math::GMPz::Rmpz_fits_ulong_p($u) || die \"Too large value!\";\n\n        my $hi = Math::GMPz::Rmpz_get_ui($u);\n\n        $lo > $hi && return;\n\n        # Pinch's bound for the second to last prime\n        if ($k == 2 and Math::GMPz::Rmpz_cmp_ui($m, 1_000) <= 0) {\n            my $m_ui  = Math::GMPz::Rmpz_get_ui($m);\n            my $bound = 2 * $m_ui * $m_ui - 3 * $m_ui + 2;\n            if ($hi > $bound) {\n                $hi = $bound;\n                $lo > $hi && return;\n            }\n        }\n\n        if ($k == 1) {\n\n            $hi = $max_p                      if ($max_p < $hi);\n            $hi = Math::GMPz::Rmpz_get_ui($m) if (Math::GMPz::Rmpz_cmp_ui($m, $hi) < 0);\n            Math::GMPz::Rmpz_cdiv_q($u, $A, $m);\n\n            if (Math::GMPz::Rmpz_fits_ulong_p($u)) {\n                $lo = vecmax($lo, Math::GMPz::Rmpz_get_ui($u));\n            }\n            elsif (Math::GMPz::Rmpz_cmp_ui($u, $lo) > 0) {\n                if (Math::GMPz::Rmpz_cmp_ui($u, $hi) > 0) {\n                    return;\n                }\n                $lo = Math::GMPz::Rmpz_get_ui($u);\n            }\n\n            if ($lo > $hi) {\n                return;\n            }\n\n            Math::GMPz::Rmpz_invert($v, $m, $L);\n\n            if (Math::GMPz::Rmpz_cmp_ui($v, $hi) > 0) {\n                return;\n            }\n\n            if (Math::GMPz::Rmpz_fits_ulong_p($L)) {\n                $L = Math::GMPz::Rmpz_get_ui($L);\n            }\n\n            my $t = Math::GMPz::Rmpz_get_ui($v);\n            $t > $hi && return;\n\n            my $inv_m = $t;\n            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);\n            $t > $hi && return;\n\n            for (my $p = $t ; $p <= $hi ; $p += $L) {\n                if (is_prime($p)) {\n                    Math::GMPz::Rmpz_mul_ui($v, $m, $p);\n                    Math::GMPz::Rmpz_sub_ui($u, $v, 1);\n                    if (Math::GMPz::Rmpz_divisible_ui_p($u, $p - 1)) {\n                        push @list, Math::GMPz::Rmpz_init_set($v);\n                    }\n                }\n            }\n\n            return;\n        }\n\n        my $z   = Math::GMPz::Rmpz_init();\n        my $lcm = Math::GMPz::Rmpz_init();\n\n        foreach my $p (@{primes($lo, $hi)}) {\n\n            Math::GMPz::Rmpz_gcd_ui($Math::GMPz::NULL, $m, $p >> 1) == 1 or next;\n            Math::GMPz::Rmpz_lcm_ui($lcm, $L, $p - 1);\n            Math::GMPz::Rmpz_mul_ui($z, $m, $p);\n\n            __SUB__->($z, $lcm, $p + 1, $k - 1);\n        }\n      }\n      ->(Math::GMPz->new(1), Math::GMPz->new(1), 3, $k);\n\n    return sort { $a <=> $b } @list;\n}\n\nmy $from = 1;\nmy $upto = powint(10, 10);\n\nforeach my $k (3 .. 7) {\n    my @arr = carmichael_numbers_in_range($from, $upto, $k);\n    say \"There are: \", scalar(@arr), \" Carmichael numbers <= $upto with $k prime factors\";\n}\n\n__END__\nThere are: 335 Carmichael numbers <= 10000000000 with 3 prime factors\nThere are: 619 Carmichael numbers <= 10000000000 with 4 prime factors\nThere are: 492 Carmichael numbers <= 10000000000 with 5 prime factors\nThere are: 99 Carmichael numbers <= 10000000000 with 6 prime factors\nThere are: 2 Carmichael numbers <= 10000000000 with 7 prime factors\n"
  },
  {
    "path": "Math/carmichael_numbers_random.pl",
    "content": "#!/usr/bin/perl\n\n# Generate random Carmichael numbers of the form (k+1)*(2*k+1)*(3*k+1), where k+1, 2*k+1 and 3*k+1 are all primes.\n\n# See also:\n#   https://oeis.org/A033502 -- Carmichael numbers of the form (6*k+1)*(12*k+1)*(18*k+1)\n#   https://oeis.org/A255441 -- Carmichael numbers of the form (60k+41)(90k+61)(150k+101)\n#   https://oeis.org/A255514 -- Carmichael numbers of the form (24*k+13)*(72*k+37)*(192*k+97)\n#   https://oeis.org/A182085 -- Carmichael numbers of the form (30k+7)*(60k+13)*(150k+31)\n#   https://oeis.org/A182088 -- Carmichael numbers of the form (30n-29)*(60n-59)*(90n-89)*(180n-179)\n#   https://oeis.org/A182132 -- Carmichael numbers of the form (30n-7)*(90n-23)*(300n-79)\n#   https://oeis.org/A182133 -- Carmichael numbers of the form (30n-17)*(90n-53)*(150n-89)\n#   https://oeis.org/A182416 -- Carmichael numbers of the form (60k+13)*(180k+37)*(300k+61)\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse Math::GMPz;\nuse Math::Prime::Util::GMP qw(is_prob_prime vecprod random_ndigit_prime);\n\nsub random_carmichael_number ($n = 20) {\n\n    $n = 2 if ($n <= 1);\n\n    while (1) {\n        my $p = Math::GMPz::Rmpz_init_set_str(random_ndigit_prime($n), 10);\n        my $k = ($p - 1);\n        is_prob_prime(2*$k + 1) && is_prob_prime(3*$k + 1) or next;\n        return ($p, 2*$k + 1, 3*$k + 1);\n    }\n}\n\nforeach my $n (2 .. 20) {\n\n    my @factors    = random_carmichael_number($n);\n    my $carmichael = vecprod(@factors);\n\n    say \"$carmichael = \", join(' * ', @factors);\n}\n\n__END__\n294409 = 37 * 73 * 109\n56052361 = 211 * 421 * 631\n71171308081 = 2281 * 4561 * 6841\n129140929242289 = 27817 * 55633 * 83449\n472631192510407921 = 428671 * 857341 * 1286011\n27572283826108082569 = 1662547 * 3325093 * 4987639\n345721500688805466654601 = 38624101 * 77248201 * 115872301\n130699973774636844248473489 = 279281017 * 558562033 * 837843049\n27673744421175202436239020169 = 1664583397 * 3329166793 * 4993750189\n328972311969416805526009802207569 = 37990006297 * 75980012593 * 113970018889\n2154063839571860482226489311256938129 = 710726387407 * 1421452774813 * 2132179162219\n570115866940668362539466801338334994649 = 4563211789627 * 9126423579253 * 13689635368879\n1782421577597012564570834220077888509756969 = 66724663694947 * 133449327389893 * 200173991084839\n52582793280275762357474570728765725923205529 = 206172530234557 * 412345060469113 * 618517590703669\n278521214364869103131896930517366707497856421161 = 3593925000970261 * 7187850001940521 * 10781775002910781\n1033219900193456185960963387986087314925660018643009 = 55634881918514887 * 111269763837029773 * 166904645755544659\n1081644507889807242059050179401322818854661656619742361 = 564908053691846461 * 1129816107383692921 * 1694724161075539381\n341413647754278719970853443358101430514668165478272427161 = 3846300480078170011 * 7692600960156340021 * 11538901440234510031\n6271289738172907436343660234664403558286290715038000756209 = 10148500369293939337 * 20297000738587878673 * 30445501107881818009\n"
  },
  {
    "path": "Math/carmichael_strong_fermat_pseudoprimes_in_range.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 24 September 2022\n# https://github.com/trizen\n\n# Generate all the Carmichael numbers with n prime factors in a given range [A,B] that are also strong Fermat pseudoprimes to a given base. (not in sorted order)\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\n=for comment\n\n# PARI/GP program:\ncarmichael_strong_psp(A, B, k, base) = A=max(A, vecprod(primes(k+1))\\2); (f(m, l, p, k, k_exp, congr, u=0, v=0) = my(list=List()); if(k==1, forprime(q=u, v, my(t=m*q); if((t-1)%l == 0 && (t-1)%(q-1) == 0, my(tv=valuation(q-1, 2)); if(tv > k_exp && Mod(base, q)^(((q-1)>>tv)<<k_exp) == congr, listput(list, t)))), forprime(q = p, sqrtnint(B\\m, k), if(base%q != 0, my(tv=valuation(q-1, 2)); if(tv > k_exp && Mod(base, q)^(((q-1)>>tv)<<k_exp) == congr, my(L=lcm(l, q-1)); if(gcd(L, m) == 1, my(t = m*q, u=ceil(A/t), v=B\\t); if(u <= v, my(r=nextprime(q+1)); if(k==2 && r>u, u=r); list=concat(list, f(t, L, r, k-1, k_exp, congr, u, v)))))))); list); my(res=f(1, 1, 3, k, 0, 1)); for(v=0, logint(B, 2), res=concat(res, f(1, 1, 3, k, v, -1))); vecsort(Vec(res));\n\n=cut\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\n\nsub carmichael_strong_fermat_in_range ($A, $B, $k, $base) {\n\n    $A = vecmax($A, pn_primorial($k + 1) >> 1);\n\n    if ($A > $B) {\n        return;\n    }\n\n    # Largest possisble prime factor for Carmichael numbers <= B\n    my $max_p = (1 + sqrtint(8 * $B + 1)) >> 2;\n\n    my @list;\n\n    my $generator = sub ($m, $L, $lo, $k, $k_exp, $congr) {\n\n        my $hi = vecmin($max_p, rootint(divint($B, $m), $k));\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        if ($k == 1) {\n\n            $lo = vecmax($lo, cdivint($A, $m));\n            $lo > $hi && return;\n\n            my $t = invmod($m, $L);\n            $t > $hi && return;\n            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);\n\n            for (my $p = $t ; $p <= $hi ; $p += $L) {\n                if (($m * $p - 1) % ($p - 1) == 0 and is_prime($p) and $base % $p != 0) {\n                    my $val = valuation($p - 1, 2);\n                    if ($val > $k_exp and powmod($base, ($p - 1) >> ($val - $k_exp), $p) == ($congr % $p)) {\n                        push @list, $m * $p;\n                    }\n                }\n            }\n\n            return;\n        }\n\n        foreach my $p (@{primes($lo, $hi)}) {\n\n            gcd($m, $p - 1) == 1 or next;\n            $base % $p == 0 and next;\n\n            my $val = valuation($p - 1, 2);\n            $val > $k_exp                                                   or next;\n            powmod($base, ($p - 1) >> ($val - $k_exp), $p) == ($congr % $p) or next;\n\n            # gcd($m*$p, euler_phi($m*$p)) == 1 or die \"$m*$p: not cyclic\";\n\n            __SUB__->($m * $p, lcm($L, $p - 1), $p + 1, $k - 1, $k_exp, $congr);\n        }\n    };\n\n    # Case where 2^d == 1 (mod p), where d is the odd part of p-1.\n    $generator->(1, 1, 3, $k, 0, 1);\n\n    # Cases where 2^(d * 2^v) == -1 (mod p), for some v >= 0.\n    foreach my $v (0 .. logint($B, 2)) {\n        $generator->(1, 1, 3, $k, $v, -1);\n    }\n\n    return sort { $a <=> $b } @list;\n}\n\n# Generate all the 3-Carmichael numbers in the range [1, 10^8] that are also strong pseudoprimes to base 2.\n\nmy $k    = 3;\nmy $base = 2;\nmy $from = 1;\nmy $upto = 1e8;\n\nmy @arr = carmichael_strong_fermat_in_range($from, $upto, $k, $base);\nsay join(', ', @arr);\n\n__END__\n15841, 29341, 52633, 252601, 314821, 1909001, 3581761, 4335241, 5049001, 5444489, 15247621, 29111881, 35703361, 36765901, 53711113, 68154001, 99036001\n"
  },
  {
    "path": "Math/carmichael_strong_fermat_pseudoprimes_in_range_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 05 March 2023\n# https://github.com/trizen\n\n# Generate all the Carmichael numbers with n prime factors in a given range [A,B] that are also strong Fermat pseudoprimes to a given base. (not in sorted order)\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\n=for comment\n\n# PARI/GP program:\n\ncarmichael_strong_psp(A, B, k, base) = A=max(A, vecprod(primes(k+1))\\2); (f(m, l, p, k, k_exp, congr, u=0, v=0) = my(list=List()); if(k==1, forprime(q=u, v, my(t=m*q); if((t-1)%l == 0 && (t-1)%(q-1) == 0, my(tv=valuation(q-1, 2)); if(tv > k_exp && Mod(base, q)^(((q-1)>>tv)<<k_exp) == congr, listput(list, t)))), forprime(q = p, sqrtnint(B\\m, k), if(base%q != 0, my(tv=valuation(q-1, 2)); if(tv > k_exp && Mod(base, q)^(((q-1)>>tv)<<k_exp) == congr, my(L=lcm(l, q-1)); if(gcd(L, m) == 1, my(t = m*q, u=ceil(A/t), v=B\\t); if(u <= v, my(r=nextprime(q+1)); if(k==2 && r>u, u=r); list=concat(list, f(t, L, r, k-1, k_exp, congr, u, v)))))))); list); my(res=f(1, 1, 3, k, 0, 1)); for(v=0, logint(B, 2), res=concat(res, f(1, 1, 3, k, v, -1))); vecsort(Vec(res));\n\n=cut\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory 0.74 qw(:all);\n\nsub carmichael_strong_fermat_in_range ($A, $B, $k, $base) {\n\n    $A = vecmax($A, Math::GMPz->new(pn_primorial($k)));\n\n    $A = Math::GMPz->new(\"$A\");\n    $B = Math::GMPz->new(\"$B\");\n\n    $A > $B and return;\n\n    my $u = Math::GMPz::Rmpz_init();\n    my $v = Math::GMPz::Rmpz_init();\n\n    # max_p = floor((1 + sqrt(8*B + 1))/4)\n    my $max_p = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_mul_2exp($max_p, $B, 3);\n    Math::GMPz::Rmpz_add_ui($max_p, $max_p, 1);\n    Math::GMPz::Rmpz_sqrt($max_p, $max_p);\n    Math::GMPz::Rmpz_add_ui($max_p, $max_p, 1);\n    Math::GMPz::Rmpz_div_2exp($max_p, $max_p, 2);\n    $max_p = Math::GMPz::Rmpz_get_ui($max_p) if Math::GMPz::Rmpz_fits_ulong_p($max_p);\n\n    my @list;\n\n    my $generator = sub ($m, $L, $lo, $k, $k_exp, $congr) {\n\n        Math::GMPz::Rmpz_tdiv_q($u, $B, $m);\n        Math::GMPz::Rmpz_root($u, $u, $k);\n\n        Math::GMPz::Rmpz_fits_ulong_p($u) || die \"Too large value!\";\n\n        my $hi = Math::GMPz::Rmpz_get_ui($u);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        if ($k == 1) {\n\n            $hi = $max_p if ($max_p < $hi);\n            Math::GMPz::Rmpz_cdiv_q($u, $A, $m);\n\n            if (Math::GMPz::Rmpz_fits_ulong_p($u)) {\n                $lo = vecmax($lo, Math::GMPz::Rmpz_get_ui($u));\n            }\n            elsif (Math::GMPz::Rmpz_cmp_ui($u, $lo) > 0) {\n                if (Math::GMPz::Rmpz_cmp_ui($u, $hi) > 0) {\n                    return;\n                }\n                $lo = Math::GMPz::Rmpz_get_ui($u);\n            }\n\n            if ($lo > $hi) {\n                return;\n            }\n\n            Math::GMPz::Rmpz_invert($v, $m, $L);\n\n            if (Math::GMPz::Rmpz_cmp_ui($v, $hi) > 0) {\n                return;\n            }\n\n            if (Math::GMPz::Rmpz_fits_ulong_p($L)) {\n                $L = Math::GMPz::Rmpz_get_ui($L);\n            }\n\n            my $t = Math::GMPz::Rmpz_get_ui($v);\n            $t > $hi && return;\n            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);\n\n            for (my $p = $t ; $p <= $hi ; $p += $L) {\n                if (is_prime($p)) {\n                    my $valuation = valuation($p - 1, 2);\n                    if ($valuation > $k_exp and powmod($base, ($p - 1) >> ($valuation - $k_exp), $p) == ($congr % $p)) {\n                        Math::GMPz::Rmpz_mul_ui($v, $m, $p);\n                        Math::GMPz::Rmpz_sub_ui($u, $v, 1);\n                        if (Math::GMPz::Rmpz_divisible_ui_p($u, $p - 1)) {\n                            push(@list, Math::GMPz::Rmpz_init_set($v));\n                        }\n                    }\n                }\n            }\n\n            return;\n        }\n\n        my $z   = Math::GMPz::Rmpz_init();\n        my $lcm = Math::GMPz::Rmpz_init();\n\n        foreach my $p (@{primes($lo, $hi)}) {\n\n            $base % $p == 0 and next;\n            Math::GMPz::Rmpz_gcd_ui($Math::GMPz::NULL, $m, $p - 1) == 1 or next;\n\n            my $valuation = valuation($p - 1, 2);\n            $valuation > $k_exp                                                   or next;\n            powmod($base, ($p - 1) >> ($valuation - $k_exp), $p) == ($congr % $p) or next;\n\n            Math::GMPz::Rmpz_mul_ui($z, $m, $p);\n            Math::GMPz::Rmpz_lcm_ui($lcm, $L, $p - 1);\n\n            __SUB__->($z, $lcm, $p + 1, $k - 1, $k_exp, $congr);\n        }\n    };\n\n    # Cases where 2^(d * 2^v) == -1 (mod p), for some v >= 0.\n    foreach my $v (0 .. logint($B, 2)) {\n        $generator->(Math::GMPz->new(1), Math::GMPz->new(1), 2, $k, $v, -1);\n    }\n\n    # Case where 2^d == 1 (mod p), where d is the odd part of p-1.\n    $generator->(Math::GMPz->new(1), Math::GMPz->new(1), 2, $k, 0, 1);\n\n    return sort { $a <=> $b } @list;\n}\n\n# Generate all the 3-Carmichael numbers in the range [1, 10^8] that are also strong pseudoprimes to base 2.\n\nmy $k    = 3;\nmy $base = 2;\nmy $from = 1;\nmy $upto = 1e8;\n\nmy @arr = carmichael_strong_fermat_in_range($from, $upto, $k, $base);\nsay join(', ', @arr);\n\n__END__\n15841, 29341, 52633, 252601, 314821, 1909001, 3581761, 4335241, 5049001, 5444489, 15247621, 29111881, 35703361, 36765901, 53711113, 68154001, 99036001\n"
  },
  {
    "path": "Math/cartesian_product_iter.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 23 April 2017\n# https://github.com/trizen\n\n# Iterative algorithm for computing the Cartesian product.\n\n# Algorithm from:\n#   https://stackoverflow.com/a/10947389\n\nuse 5.016;\nuse warnings;\n\nsub cartesian(&@) {\n    my ($callback, @arrs) = @_;\n\n    my ($more, @lengths);\n\n    foreach my $arr (@arrs) {\n        my $end = $#{$arr};\n\n        if ($end >= 0) {\n            $more ||= 1;\n        }\n        else {\n            $more = 0;\n            last;\n        }\n\n        push @lengths, $end;\n    }\n\n    my @temp;\n    my @indices = (0) x @arrs;\n\n    while ($more) {\n        @temp = @indices;\n\n        for (my $i = $#indices ; $i >= 0 ; --$i) {\n            if ($indices[$i] == $lengths[$i]) {\n                $indices[$i] = 0;\n                $more = 0 if $i == 0;\n            }\n            else {\n                ++$indices[$i];\n                last;\n            }\n        }\n\n        $callback->(map { $_->[CORE::shift(@temp)] } @arrs);\n    }\n}\n\ncartesian {\n    say \"@_\";\n} (['a', 'b'], ['c', 'd', 'e'], ['f', 'g']);\n"
  },
  {
    "path": "Math/cartesian_product_rec.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 23 April 2017\n# https://github.com/trizen\n\n# Recursive algorithm for computing the Cartesian product.\n\n# Algorithm from Math::Cartesian::Product\n#   https://metacpan.org/pod/Math::Cartesian::Product\n\nuse 5.016;\nuse warnings;\n\nsub cartesian(&@) {\n    my ($callback, @C) = @_;\n    my (@c, @r);\n\n    sub {\n        if (@c < @C) {\n            for my $item (@{$C[@c]}) {\n                CORE::push(@c, $item);\n                __SUB__->();\n                CORE::pop(@c);\n            }\n        }\n        else {\n            $callback->(@c);\n        }\n      }\n      ->();\n}\n\ncartesian {\n    say \"@_\";\n} (['a', 'b'], ['c', 'd', 'e'], ['f', 'g']);\n"
  },
  {
    "path": "Math/cauchy_numbers_of_first_type.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 09 February 2018\n# https://github.com/trizen\n\n# A new algorithm for computing the Cauchy numbers of first type.\n\n# See also:\n#   https://oeis.org/A006232    (numerators)\n#   https://oeis.org/A006233    (denominators)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload factorial);\n\nsub cauchy_numbers {\n    my ($n) = @_;\n\n    my @C = (1);\n\n    foreach my $i (1 .. $n) {\n        foreach my $k (0 .. $i - 1) {\n            $C[$i] -= $C[$k] / ($i - $k + 1);\n        }\n    }\n\n    map { (-1)**$_ * $C[$_] * factorial($_) } 0 .. $#C;\n}\n\nmy @cauchy = cauchy_numbers(30);\n\nforeach my $i (0 .. $#cauchy) {\n    printf \"C(%2d) = %40s / %s\\n\", $i, $cauchy[$i]->nude;\n}\n\n__END__\nC( 0) =                                        1 / 1\nC( 1) =                                        1 / 2\nC( 2) =                                       -1 / 6\nC( 3) =                                        1 / 4\nC( 4) =                                      -19 / 30\nC( 5) =                                        9 / 4\nC( 6) =                                     -863 / 84\nC( 7) =                                     1375 / 24\nC( 8) =                                   -33953 / 90\nC( 9) =                                    57281 / 20\nC(10) =                                 -3250433 / 132\nC(11) =                                  1891755 / 8\nC(12) =                             -13695779093 / 5460\nC(13) =                              24466579093 / 840\nC(14) =                            -132282840127 / 360\nC(15) =                             240208245823 / 48\nC(16) =                         -111956703448001 / 1530\nC(17) =                            4573423873125 / 4\nC(18) =                       -30342376302478019 / 1596\nC(19) =                        56310194579604163 / 168\nC(20) =                    -12365722323469980029 / 1980\nC(21) =                    161867055619224199787 / 1320\nC(22) =                 -20953816286242674495191 / 8280\nC(23) =                   4380881778942163832799 / 80\nC(24) =             -101543126947618093900697699 / 81900\nC(25) =              192060902780872132330221667 / 6552\nC(26) =            -1092286933245454564213092649 / 1512\nC(27) =             2075032177476967189228515625 / 112\nC(28) =         -1718089509598695642524656240811 / 3480\nC(29) =          1092041494691940355778302728249 / 80\nC(30) =     -44810233755305010150728029810063187 / 114576\n"
  },
  {
    "path": "Math/chebyshev_factorization_method.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 23 January 2020\n# https://github.com/trizen\n\n# A simple factorization method, using the Chebyshev T_n(x) polynomials, based on the identity:\n#   T_{m n}(x) = T_m(T_n(x))\n\n# where:\n#   T_n(x) = (1/2) * V_n(2x, 1)\n\n# where V_n(P, Q) is the Lucas V sequence.\n\n# See also:\n#   https://oeis.org/A001075\n#   https://en.wikipedia.org/wiki/Lucas_sequence\n#   https://en.wikipedia.org/wiki/Iterated_function\n#   https://en.wikipedia.org/wiki/Chebyshev_polynomials\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse ntheory      qw(prime_iterator sqrtint primes logint);\nuse Math::AnyNum qw(:overload lucasVmod gcd invmod mulmod is_coprime);\n\nsub chebyshev_factorization ($n, $B = logint($n, 2)**2, $a = 127) {\n\n    my $x = $a;\n    my $G = $B * $B;\n    my $i = invmod(2, $n);\n\n    my sub chebyshevTmod ($a, $x) {\n        mulmod(lucasVmod(2 * $x, 1, $a, $n), $i, $n);\n    }\n\n    foreach my $p (@{primes(2, sqrtint($B))}) {\n        for (1 .. logint($G, $p)) {\n            $x = chebyshevTmod($p, $x);    # T_k(x) (mod n)\n        }\n    }\n\n    my $it = prime_iterator(sqrtint($B) + 1);\n    for (my $p = $it->() ; $p <= $B ; $p = $it->()) {\n        $x = chebyshevTmod($p, $x);        # T_k(x) (mod n)\n        is_coprime($x - 1, $n) || return gcd($x - 1, $n);\n    }\n\n    return gcd($x - 1, $n);\n}\n\nsay chebyshev_factorization(2**64 + 1,                     20);      #=> 274177           (p-1 is   20-smooth)\nsay chebyshev_factorization(257221 * 470783,               1000);    #=> 470783           (p-1 is 1000-smooth)\nsay chebyshev_factorization(1124075136413 * 3556516507813, 4000);    #=> 1124075136413    (p+1 is 4000-smooth)\nsay chebyshev_factorization(7553377229 * 588103349,        800);     #=> 7553377229       (p+1 is  800-smooth)\n\nsay '';\n\nsay chebyshev_factorization(333732865481 * 1632480277613, 3000);     #=> 333732865481     (p-1 is 3000-smooth)\nsay chebyshev_factorization(15597344393 * 12388291753,    3000);     #=> 15597344393      (p-1 is 3000-smooth)\nsay chebyshev_factorization(43759958467 * 59037829639,    3200);     #=> 43759958467      (p+1 is 3200-smooth)\nsay chebyshev_factorization(112601635303 * 83979783007,   700);      #=> 112601635303     (p-1 is  700-smooth)\nsay chebyshev_factorization(228640480273 * 224774973299,  2000);     #=> 228640480273     (p-1 is 2000-smooth)\n\nsay '';\n\nsay chebyshev_factorization(5140059121 * 8382882743,     2500);      #=> 5140059121       (p-1 is 2500-smooth)\nsay chebyshev_factorization(18114813019 * 17402508649,   6000);      #=> 18114813019      (p+1 is 6000-smooth)\nsay chebyshev_factorization(533091092393 * 440050095029, 300);       #=> 533091092393     (p+1 is  300-smooth)\n"
  },
  {
    "path": "Math/chebyshev_factorization_method_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 22 June 2020\n# https://github.com/trizen\n\n# A simple factorization method, using the Chebyshev T_n(x) polynomials, based on the identity:\n#   T_{m n}(x) = T_m(T_n(x))\n\n# where:\n#   T_n(x) = (1/2) * V_n(2x, 1)\n\n# where V_n(P, Q) is the Lucas V sequence.\n\n# See also:\n#   https://oeis.org/A001075\n#   https://en.wikipedia.org/wiki/Lucas_sequence\n#   https://en.wikipedia.org/wiki/Iterated_function\n#   https://en.wikipedia.org/wiki/Chebyshev_polynomials\n\nuse 5.020;\nuse warnings;\n\nuse Math::GMPz;\nuse ntheory      qw(:all);\nuse experimental qw(signatures);\n\nsub fast_lucasVmod ($P, $n, $m) {    # assumes Q = 1\n\n    my ($V1, $V2) = (Math::GMPz::Rmpz_init_set_ui(2), Math::GMPz::Rmpz_init_set($P));\n\n    foreach my $bit (todigits($n, 2)) {\n\n        if ($bit) {\n            Math::GMPz::Rmpz_mul($V1, $V1, $V2);\n            Math::GMPz::Rmpz_powm_ui($V2, $V2, 2, $m);\n            Math::GMPz::Rmpz_sub($V1, $V1, $P);\n            Math::GMPz::Rmpz_sub_ui($V2, $V2, 2);\n            Math::GMPz::Rmpz_mod($V1, $V1, $m);\n        }\n        else {\n            Math::GMPz::Rmpz_mul($V2, $V2, $V1);\n            Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $m);\n            Math::GMPz::Rmpz_sub($V2, $V2, $P);\n            Math::GMPz::Rmpz_sub_ui($V1, $V1, 2);\n            Math::GMPz::Rmpz_mod($V2, $V2, $m);\n        }\n    }\n\n    Math::GMPz::Rmpz_mod($V1, $V1, $m);\n\n    return $V1;\n}\n\nsub chebyshev_factorization ($n, $B, $A = 127) {\n\n    # The Chebyshev factorization method, taking\n    # advantage of the smoothness of p-1 or p+1.\n\n    if (ref($n) ne 'Math::GMPz') {\n        $n = Math::GMPz->new(\"$n\");\n    }\n\n    my $x = Math::GMPz::Rmpz_init_set_ui($A);\n    my $i = Math::GMPz::Rmpz_init_set_ui(2);\n\n    Math::GMPz::Rmpz_invert($i, $i, $n);\n\n    my sub chebyshevTmod ($A, $x) {\n        Math::GMPz::Rmpz_mul_2exp($x, $x, 1);\n        Math::GMPz::Rmpz_set($x, fast_lucasVmod($x, $A, $n));\n        Math::GMPz::Rmpz_mul($x, $x, $i);\n        Math::GMPz::Rmpz_mod($x, $x, $n);\n    }\n\n    my $g   = Math::GMPz::Rmpz_init();\n    my $lnB = log($B);\n\n    foreach my $p (@{primes(sqrtint($B))}) {\n        chebyshevTmod($p**int($lnB / log($p)), $x);\n    }\n\n    my $it = prime_iterator(sqrtint($B) + 1);\n    for (my $p = $it->() ; $p <= $B ; $p = $it->()) {\n\n        chebyshevTmod($p, $x);    # T_k(x) (mod n)\n\n        Math::GMPz::Rmpz_sub_ui($g, $x, 1);\n        Math::GMPz::Rmpz_gcd($g, $g, $n);\n\n        if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {\n            return 1 if (Math::GMPz::Rmpz_cmp($g, $n) == 0);\n            return $g;\n        }\n    }\n\n    return 1;\n}\n\nforeach my $n (\n#<<<\n    Math::GMPz->new(\"4687127904923490705199145598250386612169614860009202665502614423768156352727760127429892667212102542891417456048601608730032271\"),\n    Math::GMPz->new(\"2593364104508085171532503084981517253915662037671433715309875378319680421662639847819831785007087909697206133969480076353307875655764139224094652151\"),\n    Math::GMPz->new(\"850794313761232105411847937800407457007819033797145693534409492587965757152430334305470463047097051354064302867874781454865376206137258603646386442018830837206634789761772899105582760694829533973614585552733\"),\n#>>>\n  ) {\n\n    say \"\\n:: Factoring: $n\";\n\n    until (is_prime($n)) {\n\n        my $x = int(rand(1e6));\n        my $p = chebyshev_factorization($n, 500_000, $x);\n\n        if ($p > 1) {\n            say \"-> Found factor: $p\";\n            $n /= $p;\n        }\n    }\n}\n\n__END__\n:: Factoring: 4687127904923490705199145598250386612169614860009202665502614423768156352727760127429892667212102542891417456048601608730032271\n-> Found factor: 31935028572177122017\n-> Found factor: 441214532298715667413\n-> Found factor: 515113549791151291993\n-> Found factor: 896466791041143516471427\n-> Found factor: 12993757635350024510533\n\n:: Factoring: 2593364104508085171532503084981517253915662037671433715309875378319680421662639847819831785007087909697206133969480076353307875655764139224094652151\n-> Found factor: 1927199759971282921\n-> Found factor: 85625333993726265061\n-> Found factor: 2490501032020173490009\n-> Found factor: 765996534730183701229\n-> Found factor: 58637507352579687279739\n-> Found factor: 4393290631695328772611\n\n:: Factoring: 850794313761232105411847937800407457007819033797145693534409492587965757152430334305470463047097051354064302867874781454865376206137258603646386442018830837206634789761772899105582760694829533973614585552733\n-> Found factor: 556010720288850785597\n-> Found factor: 33311699120128903709\n-> Found factor: 341190041753756943379\n-> Found factor: 182229202433843943841\n-> Found factor: 55554864549706093104640631\n-> Found factor: 7672247345452118779313\n-> Found factor: 386663601339343857313\n-> Found factor: 5658991130760772523\n-> Found factor: 1021051300200039481\n"
  },
  {
    "path": "Math/chernick-carmichael_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 16 May 2019\n# https://github.com/trizen\n\n# Generate the smallest extended Chernick-Carmichael number with n prime factors.\n\n# OEIS sequence:\n#   https://oeis.org/A318646 -- The least Chernick's \"universal form\" Carmichael number with n prime factors.\n\n# See also:\n#   https://oeis.org/wiki/Carmichael_numbers\n#   https://www.ams.org/journals/bull/1939-45-04/S0002-9904-1939-06953-X/home.html\n\nuse 5.020;\nuse warnings;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\n# Generate the factors of a Chernick-Carmichael number\nsub chernick_carmichael_factors ($n, $m) {\n    (6*$m + 1, 12*$m + 1, (map { ((9*$m) << $_) + 1 } 1 .. $n - 2));\n}\n\n# Check the conditions for an extended Chernick-Carmichael number\nsub is_chernick_carmichael ($n, $m) {\n    foreach my $k (2 .. $n-2) {\n        is_prime(((9*$m) << $k) + 1) || return 0;\n    }\n    return 1;\n}\n\n# Find the smallest Chernick-Carmichael number with n prime factors.\nsub chernick_carmichael_number ($n, $callback) {\n\n    # `m` must be divisible by 2^(n-4), for n > 4\n    my $multiplier = ($n > 4) ? (1 << ($n - 4)) : 1;\n\n    # Optimization for n > 5\n    $multiplier *= 5 if ($n > 5);\n\n    for (my $k = 1 ; ; ++$k) {\n        my $m = $k * $multiplier;\n        if (is_prime(6*$m + 1) and is_prime(12*$m + 1) and is_prime(18*$m + 1) and is_chernick_carmichael($n, $m)) {\n            $callback->(chernick_carmichael_factors($n, $m));\n            last;\n        }\n    }\n}\n\nforeach my $n (3 .. 9) {\n    chernick_carmichael_number($n, sub (@f) { say \"a($n) = \", vecprod(@f) });\n}\n\n__END__\na(3) = 1729\na(4) = 63973\na(5) = 26641259752490421121\na(6) = 1457836374916028334162241\na(7) = 24541683183872873851606952966798288052977151461406721\na(8) = 53487697914261966820654105730041031613370337776541835775672321\na(9) = 58571442634534443082821160508299574798027946748324125518533225605795841\n"
  },
  {
    "path": "Math/chernick-carmichael_numbers_below_limit.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 22 July 2018\n# https://github.com/trizen\n\n# Generate all the extended Chernick's Carmichael numbers below a certain limit.\n\n# OEIS sequences:\n#   https://oeis.org/A317126\n#   https://oeis.org/A317136\n\n# See also:\n#   https://oeis.org/wiki/Carmichael_numbers\n#   https://www.ams.org/journals/bull/1939-45-04/S0002-9904-1939-06953-X/home.html\n\nuse 5.020;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\n# Generate the factors of a Chernick number, given n\n# and m, where n is the number of distinct prime factors.\nsub chernick_carmichael_factors ($n, $m) {\n    (6*$m + 1, 12*$m + 1, (map { (1 << $_) * 9*$m + 1 } 1 .. $n-2));\n}\n\n# Check the conditions for an extended Chernick-Carmichael number\nsub is_chernick_carmichael ($n, $m) {\n    ($n == 2) ? (is_prime(6*$m + 1) && is_prime(12*$m + 1))\n              : (is_prime((1 << ($n-2)) * 9*$m + 1) && __SUB__->($n-1, $m));\n}\n\nmy @terms;\nmy $limit = 0 + ($ARGV[0] // 10**15);\n\n# Generate terms with k distinct prime factors\nfor (my $n = 3 ; ; ++$n) {\n\n    # We can stop the search when:\n    #   (6*m + 1) * (12*m + 1) * Product_{i=1..n-2} (9 * 2^i * m + 1)\n    # is greater than the limit, for m=1.\n    last if vecprod(chernick_carmichael_factors($n, 1)) > $limit;\n\n    # Set the multiplier, based on the condition that `m` has to be divisible by 2^(k-4).\n    my $multiplier = ($n > 4) ? (1 << ($n-4)) : 1;\n\n    # Optimization for n > 5\n    $multiplier *= 5 if ($n > 5);\n\n    # Generate the extended Chernick numbers with n distinct prime factors,\n    # that are also Carmichael numbers, below the limit we're looking for.\n    for (my $k = 1 ; ; ++$k) {\n\n        my $m = $multiplier * $k;\n\n        # All factors must be prime\n        is_chernick_carmichael($n, $m) || next;\n\n        # Get the prime factors\n        my @f = chernick_carmichael_factors($n, $m);\n\n        # The product of these primes, gives a Carmichael number\n        my $c = vecprod(@f);\n        last if $c > $limit;\n        push @terms, $c;\n    }\n}\n\n# Sort the terms\nmy @final_terms = sort { $a <=> $b } @terms;\n\n# Display the terms\nforeach my $k (0 .. $#final_terms) {\n    say($k + 1, ' ', $final_terms[$k]);\n}\n"
  },
  {
    "path": "Math/chernick-carmichael_polynomials.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 16 February 2020\n# https://github.com/trizen\n\n# Generate the polynomials for the extended Chernick-Carmichael numbers with n prime factors.\n\n# OEIS sequence:\n#   https://oeis.org/A318646 -- The least Chernick's \"universal form\" Carmichael number with n prime factors.\n\n# See also:\n#   https://oeis.org/wiki/Carmichael_numbers\n#   https://www.ams.org/journals/bull/1939-45-04/S0002-9904-1939-06953-X/home.html\n\n# The ratios sum([C(n+1)]) / sum([C(n)]), are given by the OEIS sequence A083705,\n#   https://oeis.org/A083705\n# where sum([C(n)]) is the sum of the coefficients of the n-th Chernick-Carmichael polynomial,\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse Math::Polynomial;\nuse List::Util qw(reduce);\nuse Math::AnyNum qw(:overload sum prod);\n\nsub chernick_carmichael_factors ($n) {\n    reduce { $a * $b } (\n        Math::Polynomial->new(1, 6), Math::Polynomial->new(1, 12),\n        map { Math::Polynomial->new(1, 9 << $_) } 1 .. $n - 2\n    );\n}\n\nsay \"=> Polynomials:\";\nforeach my $n (3 .. 10) {\n    say \"C($n) = \", chernick_carmichael_factors($n);\n}\n\nsay \"\\n=> Sum of coefficients:\";\nforeach my $n (3 .. 10) {\n    say \"sum([C($n)]) = \", sum(chernick_carmichael_factors($n)->coeff);\n}\n\nsay \"\\n=> Product of coefficients:\";\nforeach my $n (3 .. 10) {\n    say \"prod([C($n)]) = \", prod(chernick_carmichael_factors($n)->coeff);\n}\n\n__END__\n=> Polynomials:\nC(3) = (1296 x^3 + 396 x^2 + 36 x + 1)\nC(4) = (46656 x^4 + 15552 x^3 + 1692 x^2 + 72 x + 1)\nC(5) = (3359232 x^5 + 1166400 x^4 + 137376 x^3 + 6876 x^2 + 144 x + 1)\nC(6) = (483729408 x^6 + 171320832 x^5 + 20948544 x^4 + 1127520 x^3 + 27612 x^2 + 288 x + 1)\nC(7) = (139314069504 x^7 + 49824129024 x^6 + 6204501504 x^5 + 345674304 x^4 + 9079776 x^3 + 110556 x^2 + 576 x + 1)\nC(8) = (80244904034304 x^8 + 28838012387328 x^7 + 3623616995328 x^6 + 205312900608 x^5 + 5575625280 x^4 + 72760032 x^3 + 442332 x^2 + 1152 x + 1)\nC(9) = (92442129447518208 x^9 + 33301635174236160 x^8 + 4203244791005184 x^7 + 240144078495744 x^6 + 6628433223168 x^5 + 89395182144 x^4 + 582326496 x^3 + 1769436 x^2 + 2304 x + 1)\nC(10) = (212986666247081951232 x^10 + 76819409570887630848 x^9 + 9717577633650180096 x^8 + 557495201645199360 x^7 + 15512054224674816 x^6 + 212594932882944 x^5 + 1431075428928 x^4 + 4659107040 x^3 + 7077852 x^2 + 4608 x + 1)\n\n=> Sum of coefficients:\nsum([C(3)]) = 1729\nsum([C(4)]) = 63973\nsum([C(5)]) = 4670029\nsum([C(6)]) = 677154205\nsum([C(7)]) = 195697565245\nsum([C(8)]) = 112917495146365\nsum([C(9)]) = 130193871903758845\nsum([C(10)]) = 300096874738164137725\n\n=> Product of coefficients:\nprod([C(3)]) = 18475776\nprod([C(4)]) = 88394777100288\nprod([C(5)]) = 532962603198108087091200\nprod([C(6)]) = 15566146576014516344690540671590727680\nprod([C(7)]) = 8607729694274768470180293645913878477204634698636066816\nprod([C(8)]) = 355900510244809815184693136856938085570466396628469022965807673827511731486720\nprod([C(9)]) = 4371202733642080997695663760838408017640388301504244892063249651693811055142174806499598124164351828951040\nprod([C(10)]) = 63565858610074701536163462529753569644918704418351291678528316792385645865008717295355264067966620308836237036012393969126437841481288908800\n"
  },
  {
    "path": "Math/chernick-carmichael_with_n_factors_sieve.pl",
    "content": "#!/usr/bin/perl\n\n# Sieve for Chernick's \"universal form\" Carmichael number with n prime factors.\n# Inspired by the PARI program by David A. Corneth from OEIS A372238.\n\n# Finding A318646(10) takes ~4 minutes.\n\n# See also:\n#   https://oeis.org/A318646\n#   https://oeis.org/A372238/a372238.gp.txt\n\nuse 5.036;\nuse ntheory     qw(:all);\nuse Time::HiRes qw (time);\n\nsub isrem($m, $p, $n) {\n\n    ( 6 * $m + 1) % $p == 0 and ( 6 * $m + 1) > $p and return;\n    (12 * $m + 1) % $p == 0 and (12 * $m + 1) > $p and return;\n\n    foreach my $k (1 .. $n - 2) {\n        my $t = (9 * $m << $k) + 1;\n        if ($t % $p == 0 and $t > $p) {\n            return;\n        }\n    }\n\n    return 1;\n}\n\nsub remaindersmodp($p, $n) {\n    grep { isrem($_, $p, $n) } (0 .. $p - 1);\n}\n\nsub remainders_for_primes($n, $primes) {\n\n    my $res = [[0, 1]];\n    my $M   = 1;\n\n    foreach my $p (@$primes) {\n\n        my @rems = remaindersmodp($p, $n);\n\n        if (scalar(@rems) == $p) {\n            next;    # skip trivial primes\n        }\n\n        if (!@rems) {\n            @rems = (0);\n        }\n\n        my @nres;\n        foreach my $r (@$res) {\n            foreach my $rem (@rems) {\n                push @nres, [chinese($r, [$rem, $p]), lcm($p, $r->[1])];\n            }\n        }\n        $res = \\@nres;\n        $M *= $p;\n    }\n\n    return ($M, [sort { $a <=> $b } map { $_->[0] } @$res]);\n}\n\nsub is($m, $n) {\n\n    is_prime( 6 * $m + 1) || return;\n    is_prime(12 * $m + 1) || return;\n    is_prime(18 * $m + 1) || return;\n\n    foreach my $k (2 .. $n - 2) {\n        is_prime((9 * $m << $k) + 1) || return;\n    }\n\n    return 1;\n}\n\nsub deltas ($integers) {\n\n    my @deltas;\n    my $prev = 0;\n\n    foreach my $n (@$integers) {\n        push @deltas, $n - $prev;\n        $prev = $n;\n    }\n\n    shift(@deltas);\n    return \\@deltas;\n}\n\nsub chernick_carmichael_factors($m, $n) {\n    (6 * $m + 1, 12 * $m + 1, (map { (9 * $m << $_) + 1 } 1 .. $n - 2));\n}\n\nsub chernick_carmichael_with_n_factors($n, $maxp = nth_prime($n)) {\n\n    my @primes = @{primes($maxp)};\n\n    my ($M, $r) = remainders_for_primes($n, \\@primes);\n    my @d = @{deltas($r)};\n    my $s = vecprod(@primes);\n\n    while (@d and $d[0] == 0) {\n        shift @d;\n    }\n\n    push @d, $r->[0] + $M - $r->[-1];\n\n    my $m      = $r->[0];\n    my $d_len  = scalar(@d);\n    my $t0     = time;\n    my $prev_m = $m;\n\n    my $two_power = vecmax(1 << ($n - 4), 1);\n\n    for (my $j = 0 ; ; ++$j) {\n\n        if ($m % $two_power == 0 and is($m, $n)) {\n            return $m;\n        }\n\n        if ($j % 1e7 == 0 and $j > 0) {\n            my $tdelta = time - $t0;\n            say \"Searching for a($n) with m = $m\";\n            say \"Performance: \", (($m - $prev_m) / 1e9) / $tdelta, \" * 10^9 terms per second\";\n            $t0     = time;\n            $prev_m = $m;\n        }\n\n        $m += $d[$j % $d_len];\n    }\n}\n\nforeach my $n (3 .. 9) {\n    my $m = chernick_carmichael_with_n_factors($n);\n    say \"[$n] m = $m\";\n\n    foreach my $k ($n .. $n + 100) {\n        my $c = vecprod(chernick_carmichael_factors($m, $k));\n        if (is_carmichael($c)) {\n            say \"[$k] $c\";\n        }\n        else {\n            last;\n        }\n    }\n\n    is_carmichael(vecprod(chernick_carmichael_factors($m, $n))) || die \"not a Carmichael number\";\n}\n\n__END__\n[3] m = 1\n[3] 1729\n[4] 63973\n[4] m = 1\n[4] 63973\n[5] m = 380\n[5] 26641259752490421121\n[6] 1457836374916028334162241\n[6] m = 380\n[6] 1457836374916028334162241\n[7] m = 780320\n[7] 24541683183872873851606952966798288052977151461406721\n[8] m = 950560\n[8] 53487697914261966820654105730041031613370337776541835775672321\n[9] 58571442634534443082821160508299574798027946748324125518533225605795841\n[9] m = 950560\n[9] 58571442634534443082821160508299574798027946748324125518533225605795841\n[10] m = 3208386195840\n[10] 24616075028246330441656912428380582403261346369700917629170235674289719437963233744091978433592331048416482649086961226304033068172880278517841921\n"
  },
  {
    "path": "Math/chinese_factorization_method.pl",
    "content": "#!/usr/bin/perl\r\n\r\n# Daniel \"Trizen\" Șuteu\r\n# Date: 01 June 2022\r\n# https://github.com/trizen\r\n\r\n# Concept for an integer factorization method based on the Chinese Remainder Theorem (CRT).\r\n\r\n# Example:\r\n#   n = 43*97\r\n\r\n# We have:\r\n#   n == 1 mod 2\r\n#   n == 1 mod 3\r\n#   n == 1 mod 5\r\n#   n == 6 mod 7\r\n#   n == 2 mod 11\r\n\r\n# 43 = chinese(Mod(1,2), Mod(1,3), Mod(3,5), Mod(1,7))\r\n# 97 = chinese(Mod(1,2), Mod(1,3), Mod(2,5), Mod(6,7))\r\n\r\n# For some small primes p, we try to find pairs of a and b, such that:\r\n#   a*b == n mod p\r\n\r\n# Then using either the `a` or the `b` values, we can construct a factor of n, using the CRT.\r\n\r\nuse 5.020;\r\nuse strict;\r\nuse warnings;\r\n\r\nuse ntheory qw(:all);\r\nuse experimental qw(signatures);\r\nuse Math::GMPz;\r\n\r\nsub CRT_factor ($n) {\r\n\r\n    return $n if is_prime($n);\r\n\r\n    my $congruences = [0];\r\n\r\n    my $LCM   = 1;\r\n    my $limit = vecmin(sqrtint($n), 1e6);\r\n\r\n    for (my $p = 2 ; $p <= $limit ; $p = next_prime($p)) {\r\n\r\n        my $r = modint($n, $p);\r\n\r\n        if ($r == 0) {\r\n            return $p;\r\n        }\r\n\r\n        my @new_congruences;\r\n\r\n        foreach my $c (@$congruences) {\r\n            foreach my $d (1 .. $p - 1) {\r\n                my $t = [$d, $p];\r\n\r\n                my $z = chinese([$c, $LCM], $t);\r\n                my $g = gcd($z, $n);\r\n\r\n                if ($g > 1 and $g < $n) {\r\n                    return $g;\r\n                }\r\n\r\n                push @new_congruences, $z;\r\n            }\r\n        }\r\n\r\n        $LCM         = lcm($LCM, $p);\r\n        $congruences = \\@new_congruences;\r\n    }\r\n\r\n    return 1;\r\n}\r\n\r\nsay CRT_factor(43 * 97);      #=> 97\r\nsay CRT_factor(503 * 863);    #=> 863\r\n\r\nsay CRT_factor(Math::GMPz->new(2)**32 + 1);    #=> 641\r\nsay CRT_factor(Math::GMPz->new(2)**64 + 1);    #=> 274177\r\n\r\nsay CRT_factor(Math::GMPz->new(\"273511610089\"));      #=> 377827\r\nsay CRT_factor(Math::GMPz->new(\"24259337155997\"));    #=> 5944711\r\n"
  },
  {
    "path": "Math/coin_change.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 14 November 2015\n# Edit: 15 May 2021\n# https://github.com/trizen\n\n# The classic coin-change problem.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse List::Util qw(sum0);\nno warnings qw(recursion);\n\nmy @denominations = (.01, .05, .1, .25, .5, 1, 2, 5, 10, 20, 50, 100);\n\nsub change {\n    my ($n, $pos, $solution) = @_;\n    my $sum = sum0(@$solution);\n\n    if ($sum == $n) {\n        return $solution;    # found a solution\n    }\n    elsif ($sum > $n or $pos > $#denominations) {\n        return;\n    }\n\n    (\n        change($n, $pos + 1, $solution),\n        change($n, $pos, [@$solution, $denominations[$pos]]),\n    )\n}\n\nmy $amount = 0.26;               # the amount of money\n\nmy @solutions = change($amount, 0, []);\nprint(\"All the possible solutions for $amount, are:\\n\");\n\nmy $best = $solutions[0];\nforeach my $s (@solutions) {\n\n    # Print the solutions\n    print(\"\\t[\" . join(\", \", @{$s}) . \"]\\n\");\n\n    # Find the best solution (which uses the minimum number of coins)\n    if (@$s < @$best) {\n        $best = $s;\n    }\n}\n\nprint(\"The best solution is: [\", join(\", \", @$best) . \"]\\n\");\n"
  },
  {
    "path": "Math/collatz_function.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 06 July 2018\n# https://github.com/trizen\n\n# The following 1628-digit number: 46785696846401151 * 3^3377 requires 41763 steps to get down to 1.\n\n# Collatz function on higher powers of 3 multiplied with n = 46785696846401151:\n#      collatz(n * 3^8818) = 101856\n#      collatz(n * 3^9071) = 106610\n#      collatz(n * 3^9296) = 108210\n#      collatz(n * 3^9586) = 110042\n#      collatz(n * 3^9660) = 113569\n#      collatz(n * 3^9870) = 113951\n\n# See also:\n#   https://oeis.org/A006877\n#   https://oeis.org/A006577\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\n\nsub collatz {\n    my ($n) = @_;\n\n    $n = Math::GMPz->new(\"$n\");\n\n    state $two = Math::GMPz::Rmpz_init_set_ui(2);\n    my $count = Math::GMPz::Rmpz_remove($n, $n, $two);\n\n    while (Math::GMPz::Rmpz_cmp_ui($n, 1) > 0) {\n\n        Math::GMPz::Rmpz_mul_ui($n, $n, 3);\n        Math::GMPz::Rmpz_add_ui($n, $n, 1);\n\n        $count += 1 + Math::GMPz::Rmpz_remove($n, $n, $two);\n    }\n\n    return $count;\n}\n\nmy $factor = Math::GMPz->new(\"46785696846401151\");\nmy $base   = Math::GMPz->new(3);\n\nmy $max = 0;\n\nforeach my $n (0 .. 2500) {\n    my $t = collatz($factor * $base**$n);\n\n    if ($t > $max) {\n        say \"collatz($factor * $base^$n) = $t\";\n        $max = $t;\n    }\n}\n"
  },
  {
    "path": "Math/complex_exponentiation_in_real_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 13 August 2017\n# https://github.com/trizen\n\n# Identity for complex exponentiation in real numbers, based on the identity:\n#\n#   exp(x*i) = cos(x) + sin(x)*i\n#\n\nuse 5.010;\nuse strict;\nuse warnings;\n\n#\n## Real base and complex exponent\n#\nsub complex_power {\n    my ($x, $r, $i) = @_;\n\n    (\n        $x**$r * cos(log($x) * $i),\n        $x**$r * sin(log($x) * $i),\n    )\n}\n\n#\n## Complex base and complex exponent\n#\nsub complex_power2 {\n    my ($x, $y, $r, $i) = @_;\n\n     ($x, $y) = (log($x*$x + $y*$y) / 2, atan2($y, $x));    # log($x + $y*i)\n     ($x, $y) = ($x*$r - $y*$i, $x*$i + $y*$r);             # ($x + $y*i) * ($r + $i*i)\n\n     (exp($x) * cos($y), exp($x) * sin($y));                # exp($x + $y*i)\n}\n\n#\n## Example for 12^(3+4i)\n#\n\n{\n    # base\n    my $x = 12;\n\n    # exponent\n    my $r = 3;\n    my $i = 4;\n\n    my ($real, $imag) = complex_power($x, $r, $i);\n\n    say \"$x^($r + $i*i) = $real + $imag*i\";   #=> -1503.99463080925 + -850.872581822307*i\n}\n\n#\n## Example for (5+2i)^(3+7i)\n#\n\n{\n    # base\n    my $x = 5;\n    my $y = 2;\n\n    # exponent\n    my $r = 3;\n    my $i = 7;\n\n    my ($real, $imag) = complex_power2($x, $y, $r, $i);\n\n    say \"($x + $y*i)^($r + $i*i) = $real + $imag*i\";    #=> 10.1847486230437 + 3.84152292303168*i\n}\n"
  },
  {
    "path": "Math/complex_logarithm_in_real_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 11 December 2017\n# https://github.com/trizen\n\n# Identity for computing the natural logarithm of a complex number, in real numbers, with the identity:\n#\n#   log(a+b*i) = log(a^2 + b^2)/2 + atan(b/a)*i\n#\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub complex_log {\n    my ($re, $im) = @_;\n\n    (\n        log($re**2 + $im**2)/2,\n        atan2($im, $re)\n    );\n}\n\n#\n## Example for log(3+5i)\n#\n\nmy $re = 3;\nmy $im = 5;\n\nmy ($real, $imag) = complex_log($re, $im);\n\nsay \"log($re + $im*i) = $real + $imag*i\";   #=> 1.76318026230808 + 1.03037682652431*i\n"
  },
  {
    "path": "Math/complex_modular_multiplicative_inverse.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 19 December 2018\n# https://github.com/trizen\n\n# Algorithm for computing the modular multiplicative inverse of complex numbers:\n#   1/a mod n, with |gcd(a, n)| = 1.\n\n# Solution to `x` for:\n#   a*x = 1 (mod n)\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload conj round);\nuse experimental qw(signatures lexical_subs);\n\nsub complex_gcd ($a, $b) {\n\n    my ($x, $y) = ($a, $b);\n\n    while ($b != 0) {\n        my $q = round($a / $b);\n        my $r = $a - $b * $q;\n\n        ($a, $b) = ($b, $r);\n    }\n\n    return $a;\n}\n\nsub complex_modular_inverse ($a, $n) {\n\n    my $g = complex_gcd($a, $n);\n\n    abs($g) == 1 or return undef;\n\n    my sub inverse ($a, $n, $i) {\n\n        my ($u, $w) = ($i, 0);\n        my ($q, $r) = (0, 0);\n\n        my $c = $n;\n\n        while ($c != 0) {\n\n            $q = round($a / $c);\n            $r = $a - $c * $q;\n\n            ($a, $c) = ($c, $r);\n            ($u, $w) = ($w, $u - $q * $w);\n        }\n\n        return $u % $n;\n    }\n\n    (grep { ($_ * $a) % $n == 1 } map { inverse($a, $n, $_) } (conj($g), 1, -1, i, -i))[0];\n}\n\nsay complex_modular_inverse(42,          2017);       #=> 1969\nsay complex_modular_inverse(3 + 4 * i,   2017);       #=> 1291+968i\nsay complex_modular_inverse(91 + 23 * i, 2017);       #=> 590+405i\nsay complex_modular_inverse(43 + 99 * i, 2017);       #=> 1709+1272i\nsay complex_modular_inverse(43 + 99 * i, 1234567);    #=> 1019551+667302i\n\n# Non-existent inverses\nsay complex_modular_inverse(43 + 99 * i, 1234) // 'undefined';    #=> undefined\n"
  },
  {
    "path": "Math/complex_zeta_in_real_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 08 August 2017\n# https://github.com/trizen\n\n# Computing the zeta function for a complex input, using only real numbers.\n\n# Defined as:\n#   zeta(a + b*i) = Sum_{n>=1} 1/n^(a + b*i)\n\n# where we have the identity:\n#   1/n^(a + b*i) = (cos(log(n) * b) - i*sin(log(n) * b)) / n**a\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nsub complex_zeta ($r = 1 / 2, $s = 14.134725142, $rep = 1e6) {\n\n    my $real = 0;\n    my $imag = 0;\n\n    foreach my $n (1 .. $rep) {\n        $real += cos(log($n) * $s) / $n**$r;\n        $imag -= sin(log($n) * $s) / $n**$r;\n    }\n\n    return ($real, $imag);\n}\n\nmy $r = 3;      # real part\nmy $s = 4;      # imaginary part\n\nmy ($real, $imag) = complex_zeta($r, $s);\nsay \"zeta($r + $s*i) =~ complex($real, $imag)\";    #=> complex(0.890554906959998, -0.0080759454242689)\n"
  },
  {
    "path": "Math/congruence_of_powers_factorization_method.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 04 July 2019\n# Edit: 22 March 2022\n# https://github.com/trizen\n\n# A simple factorization method, based on congruences of powers.\n\n# Given a composite integer `n`, if we find:\n#\n#   a^k == b^k (mod n)\n#\n# for some k >= 2, then gcd(a-b, n) may be a non-trivial factor of n.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\nuse ntheory qw(:all);\nuse Math::AnyNum qw(ipow);\nuse experimental qw(signatures);\n\nuse constant {\n              MIN_FACTOR => 1e6,    # ignore small factors\n              LOG_BRANCH => 1,      # true to use the log branch in addition to the root branch\n              FULL_RANGE => 0,      # true to use the full range from 0 to log_2(n)\n             };\n\nsub perfect_power ($n) {\n    return 1 if ($n == 0);\n    return 1 if ($n == 1);\n    return is_power($n);\n}\n\nsub cgpow_factor ($n, $verbose = 0) {\n\n    my %seen;\n\n    if (ref($n) ne 'Math::GMPz') {\n        $n = Math::GMPz->new(\"$n\");\n    }\n\n    my $f = sub ($r, $e1, $k, $e2) {\n        my @factors;\n\n        my @divs1 = divisors($e1);\n        my @divs2 = divisors($e2);\n\n        foreach my $d1 (@divs1) {\n            my $x = $r**$d1;\n            foreach my $d2 (@divs2) {\n                my $y = $k**$d2;\n                foreach my $j (-1, 1) {\n\n                    my $t = $x - $j * $y;\n                    my $g = Math::GMPz->new(gcd($t, $n));\n\n                    if ($g > MIN_FACTOR and $g < $n and !$seen{$g}++) {\n\n                        if ($verbose) {\n                            if ($r == $k) {\n                                say \"[*] Congruence of powers: a^$d1 == b^$d2 (mod n) -> $g\";\n                            }\n                            else {\n                                say \"[*] Congruence of powers: $r^$d1 == $k^$d2 (mod n) -> $g\";\n                            }\n                        }\n\n                        push @factors, $g;\n                    }\n                }\n            }\n        }\n\n        @factors;\n    };\n\n    my @params;\n    my $orig  = $n;\n    my $const = 64;\n\n    my @range;\n\n    if (FULL_RANGE) {\n        @range = reverse(2 .. logint($n, 2));\n    }\n    else {\n        @range = reverse(2 .. vecmin($const, logint($n, 2)));\n    }\n\n    my $process = sub ($root, $e) {\n\n        for my $j (1, 0) {\n\n            my $k = $root + $j;\n            my $u = powmod($k, $e, $n);\n\n            foreach my $z ($u, $n - $u) {\n\n                if (my $t = perfect_power($z)) {\n\n                    my $r1 = rootint($z, $t);\n                    ##my $r2 = rootint($z, $e);\n\n                    push @params, [Math::GMPz->new($r1), $t, Math::GMPz->new($k), $e];\n                    ##push @params, [Math::GMPz->new($r2), $e, Math::GMPz->new($k), $e];\n                }\n            }\n        }\n    };\n\n    for my $e (@range) {\n        my $root = Math::GMPz->new(rootint($n, $e));\n        $process->($root, $e);\n    }\n\n    if (LOG_BRANCH) {\n\n        for my $root (@range) {\n            my $e = Math::GMPz->new(logint($n, $root));\n            $process->($root, $e);\n        }\n\n        my %seen_param;\n        @params = grep { !$seen_param{join(' ', @$_)}++ } @params;\n    }\n\n    my @divisors;\n\n    foreach my $args (@params) {\n        push @divisors, $f->(@$args);\n    }\n\n    @divisors = sort { $a <=> $b } @divisors;\n\n    my @factors;\n    foreach my $d (@divisors) {\n        my $g = Math::GMPz->new(gcd($n, $d));\n\n        if ($g > MIN_FACTOR and $g < $n) {\n            while ($n % $g == 0) {\n                $n /= $g;\n                push @factors, $g;\n            }\n        }\n    }\n\n    push @factors, $orig / vecprod(@factors);\n    return sort { $a <=> $b } @factors;\n}\n\nif (@ARGV) {\n    say join ', ', cgpow_factor($ARGV[0], 1);\n    exit;\n}\n\n# Large roots\nsay join ' * ', cgpow_factor(ipow(1009,     24) + ipow(29,  12));\nsay join ' * ', cgpow_factor(ipow(1009,     24) - ipow(29,  12));\nsay join ' * ', cgpow_factor(ipow(59388821, 12) - ipow(151, 36));\n\nsay '-' x 80;\n\n# Small roots\nsay join ' * ', cgpow_factor(ipow(2,  256) - 1);\nsay join ' * ', cgpow_factor(ipow(10, 120) + 1);\nsay join ' * ', cgpow_factor(ipow(10, 120) - 1);\nsay join ' * ', cgpow_factor(ipow(10, 120) - 25);\nsay join ' * ', cgpow_factor(ipow(10, 105) - 1);\nsay join ' * ', cgpow_factor(ipow(10, 105) + 1);\nsay join ' * ', cgpow_factor(ipow(10, 120) - 2134 * 2134);\nsay join ' * ', cgpow_factor((ipow(2, 128) - 1) * (ipow(2, 256) - 1));\nsay join ' * ', cgpow_factor(ipow(ipow(4, 64) - 1, 3) - 1);\n\nsay join ' * ', cgpow_factor((ipow(2, 128) - 1) * (ipow(3, 128) - 1));\nsay join ' * ', cgpow_factor((ipow(5, 48) + 1) * (ipow(3, 120) + 1));\nsay join ' * ', cgpow_factor((ipow(5, 48) + 1) * (ipow(3, 120) - 1));\nsay join ' * ', cgpow_factor((ipow(5, 48) - 1) * (ipow(3, 120) + 1));\n\n__END__\n1074309286591662655506002 * 1154140443257087164049583013000044736320575461201\n1018052 * 1018110 * 1699854 * 45120343 * 14006607073 * 1036518447751 * 1074309285719975471632201\n1038960 * 5594587 * 23044763 * 61015275368249 * 534765538858459 * 4033015478857732019 * 109215797426552565244488121\n--------------------------------------------------------------------------------\n4294967295 * 4294967297 * 18446744073709551617 * 340282366920938463463374607431768211457\n100000001 * 9999999900000001 * 99999999000000009999999900000001 * 10000000099999999999999989999999899999999000000000000000100000001\n50851 * 1000001 * 1040949 * 1110111 * 1450031 * 2463661 * 2906161 * 99009901 * 99990001 * 165573604901641 * 9999000099990001 * 100009999999899989999000000010001\n999999999999999999999999999999999999999999999999999999999995 * 1000000000000000000000000000000000000000000000000000000000005\n1111111 * 1269729 * 787569631 * 900900990991 * 900009090090909909099991 * 1109988789001111109989898989900111110998878900111\n1313053 * 10000001 * 1236109099 * 61549824583 * 1099988890111109888900011 * 910009191000909089989898989899909091000919100091\n999999999999999999999999999999999999999999999999999999997866 * 1000000000000000000000000000000000000000000000000000000002134\n1114129 * 2451825 * 6700417 * 16843009 * 1103806595329 * 18446744073709551617 * 18446744073709551617 * 340282366920938463463374607431768211457\n340282366920938463463374607431768211454 * 115792089237316195423570985008687907852929702298719625575994209400481361428481\n7913 * 1109760 * 43046722 * 84215045 * 4294967297 * 926510094425921 * 18446744073709551617 * 1716841910146256242328924544641\n1273028 * 29423041 * 145127617 * 240031591394168814433 * 4892905104216215334417146433664153647610647561409\n1013824 * 1236031 * 1519505 * 43584805 * 47763361 * 1743392201 * 76293945313 * 50446744628921761 * 240031591394168814433\n1083264 * 1331139 * 1971881 * 122070313 * 29802322387695313 * 617180487788001154016207027393267755290289744417\n"
  },
  {
    "path": "Math/consecutive_partitions.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 30 April 2019\n# https://github.com/trizen\n\n# Given an array of `n` elements, generate all the possible consecutive partitions (with no swaps and go gaps).\n\n# For example, given the array [1,2,3,4,5], there are 16 different ways to\n# subdivide the array (using all of its elements in their original order):\n#\n#   [[1, 2, 3, 4, 5]]\n#   [[1], [2, 3, 4, 5]]\n#   [[1, 2], [3, 4, 5]]\n#   [[1, 2, 3], [4, 5]]\n#   [[1, 2, 3, 4], [5]]\n#   [[1], [2], [3, 4, 5]]\n#   [[1], [2, 3], [4, 5]]\n#   [[1], [2, 3, 4], [5]]\n#   [[1, 2], [3], [4, 5]]\n#   [[1, 2], [3, 4], [5]]\n#   [[1, 2, 3], [4], [5]]\n#   [[1], [2], [3], [4, 5]]\n#   [[1], [2], [3, 4], [5]]\n#   [[1], [2, 3], [4], [5]]\n#   [[1, 2], [3], [4], [5]]\n#   [[1], [2], [3], [4], [5]]\n#\n\n# In general, for a given array with `n` elements, there are `2^(n-1)` possibilities.\n\nuse 5.014;\nuse strict;\nuse warnings;\n\nuse ntheory qw(forcomb vecsum);\n\nsub split_at_indices {\n    my ($array, $indices) = @_;\n\n    my $i = 0;\n    my @parts;\n\n    foreach my $j (@$indices) {\n        push @parts, [@{$array}[$i .. $j]];\n        $i = $j + 1;\n    }\n\n    return @parts;\n}\n\nsub consecutive_partitions {\n    my (@array) = @_;\n\n    my @subsets;\n\n    foreach my $k (0 .. @array) {\n        forcomb {\n            my @t = split_at_indices(\\@array, \\@_);\n            if (vecsum(map { scalar(@$_) } @t) == @array) {\n                push @subsets, \\@t;\n            }\n        } scalar(@array), $k;\n    }\n\n    return @subsets;\n}\n\nmy @subsets = consecutive_partitions(1, 2, 3, 4, 5);\n\nforeach my $subset (@subsets) {\n    say join(', ', map { \"[@$_]\" } @$subset);\n}\n"
  },
  {
    "path": "Math/continued_fraction_expansion_of_sqrt_of_n.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 11 April 2019\n# https://github.com/trizen\n\n# Compute the simple continued fraction expansion for the square root of a given number.\n\n# Algorithm from:\n#   https://web.math.princeton.edu/mathlab/jr02fall/Periodicity/mariusjp.pdf\n\n# See also:\n#   https://en.wikipedia.org/wiki/Continued_fraction\n#   https://mathworld.wolfram.com/PeriodicContinuedFraction.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(is_square isqrt idiv);\nuse experimental qw(signatures);\n\nsub cfrac_sqrt ($n) {\n\n    my $x = isqrt($n);\n    my $y = $x;\n    my $z = 1;\n    my $r = 2 * $x;\n\n    return ($x) if is_square($n);\n\n    my @cfrac = ($x);\n\n    do {\n        $y = $r * $z - $y;\n        $z = ($n - $y*$y) / $z;\n        $r = idiv(($x + $y), $z);\n\n        push @cfrac, $r;\n    } until ($z == 1);\n\n    return @cfrac;\n}\n\nforeach my $n (1 .. 20) {\n    say \"sqrt($n) = [\", join(', ', cfrac_sqrt($n)), \"]\";\n}\n\n__END__\nsqrt(1) = [1]\nsqrt(2) = [1, 2]\nsqrt(3) = [1, 1, 2]\nsqrt(4) = [2]\nsqrt(5) = [2, 4]\nsqrt(6) = [2, 2, 4]\nsqrt(7) = [2, 1, 1, 1, 4]\nsqrt(8) = [2, 1, 4]\nsqrt(9) = [3]\nsqrt(10) = [3, 6]\nsqrt(11) = [3, 3, 6]\nsqrt(12) = [3, 2, 6]\nsqrt(13) = [3, 1, 1, 1, 1, 6]\nsqrt(14) = [3, 1, 2, 1, 6]\nsqrt(15) = [3, 1, 6]\nsqrt(16) = [4]\nsqrt(17) = [4, 8]\nsqrt(18) = [4, 4, 8]\nsqrt(19) = [4, 2, 1, 3, 1, 2, 8]\nsqrt(20) = [4, 2, 8]\n"
  },
  {
    "path": "Math/continued_fraction_expansion_of_sqrt_of_n_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 09 April 2019\n# https://github.com/trizen\n\n# Compute the simple continued fraction expansion for the square root of a given number.\n\n# Algorithm from:\n#   https://web.math.princeton.edu/mathlab/jr02fall/Periodicity/mariusjp.pdf\n\n# See also:\n#   https://en.wikipedia.org/wiki/Continued_fraction\n#   https://mathworld.wolfram.com/PeriodicContinuedFraction.html\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\n\nsub cfrac_sqrt {\n    my ($n) = @_;\n\n    $n = Math::GMPz->new(\"$n\");\n\n    my $x = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_sqrt($x, $n);\n\n    return ($x) if Math::GMPz::Rmpz_perfect_square_p($n);\n\n    my $y = Math::GMPz::Rmpz_init_set($x);\n    my $z = Math::GMPz::Rmpz_init_set_ui(1);\n    my $r = Math::GMPz::Rmpz_init();\n\n    my @cfrac = ($x);\n\n    Math::GMPz::Rmpz_add($r, $x, $x);    # r = x+x\n\n    do {\n        my $t = Math::GMPz::Rmpz_init();\n\n        # y = (r*z - y)\n        Math::GMPz::Rmpz_submul($y, $r, $z);    # y = y - t*z\n        Math::GMPz::Rmpz_neg($y, $y);           # y = -y\n\n        # z = floor((n - y*y) / z)\n        Math::GMPz::Rmpz_mul($t, $y, $y);       # t = y*y\n        Math::GMPz::Rmpz_sub($t, $n, $t);       # t = n-t\n        Math::GMPz::Rmpz_divexact($z, $t, $z);  # z = t/z\n\n        # t = floor((x + y) / z)\n        Math::GMPz::Rmpz_add($t, $x, $y);       # t = x+y\n        Math::GMPz::Rmpz_tdiv_q($t, $t, $z);    # t = floor(t/z)\n\n        $r = $t;\n        push @cfrac, $t;\n\n    } until (Math::GMPz::Rmpz_cmp_ui($z, 1) == 0);\n\n    return @cfrac;\n}\n\nforeach my $n (1 .. 20) {\n    say \"sqrt($n) = [\", join(', ', cfrac_sqrt($n)), \"]\";\n}\n\n__END__\nsqrt(1) = [1]\nsqrt(2) = [1, 2]\nsqrt(3) = [1, 1, 2]\nsqrt(4) = [2]\nsqrt(5) = [2, 4]\nsqrt(6) = [2, 2, 4]\nsqrt(7) = [2, 1, 1, 1, 4]\nsqrt(8) = [2, 1, 4]\nsqrt(9) = [3]\nsqrt(10) = [3, 6]\nsqrt(11) = [3, 3, 6]\nsqrt(12) = [3, 2, 6]\nsqrt(13) = [3, 1, 1, 1, 1, 6]\nsqrt(14) = [3, 1, 2, 1, 6]\nsqrt(15) = [3, 1, 6]\nsqrt(16) = [4]\nsqrt(17) = [4, 8]\nsqrt(18) = [4, 4, 8]\nsqrt(19) = [4, 2, 1, 3, 1, 2, 8]\nsqrt(20) = [4, 2, 8]\n"
  },
  {
    "path": "Math/continued_fraction_factorization_method.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 25 October 2018\n# https://github.com/trizen\n\n# Simple implementation of the continued fraction factorization method (CFRAC),\n# combined with modular arithmetic (variation of the Brillhart-Morrison algorithm).\n\n# See also:\n#   https://en.wikipedia.org/wiki/Pell%27s_equation\n#   https://en.wikipedia.org/wiki/Continued_fraction_factorization\n#   https://trizenx.blogspot.com/2018/10/continued-fraction-factorization-method.html\n\n# \"Gaussian elimination\" algorithm from:\n#    https://github.com/martani/Quadratic-Sieve\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Math::GMPz             qw();\nuse List::Util             qw(first);\nuse ntheory                qw(is_prime factor_exp forprimes next_prime is_square_free);\nuse Math::Prime::Util::GMP qw(is_power vecprod sqrtint rootint gcd urandomb);\n\nuse constant {\n              B_SMOOTH_METHOD => 0,    # 1 to use the B-smooth formula for the factor base\n              ROUND_DIVISION  => 0,    # 1 to use round division instead of floor division\n             };\n\nsub gaussian_elimination ($rows, $n) {\n\n    my @A   = @$rows;\n    my $m   = $#A;\n    my $ONE = Math::GMPz::Rmpz_init_set_ui(1);\n\n    my @I = map { $ONE << $_ } 0 .. $m;\n\n    my $nrow = -1;\n    my $mcol = $m < $n ? $m : $n;\n\n    foreach my $col (0 .. $mcol) {\n        my $npivot = -1;\n\n        foreach my $row ($nrow + 1 .. $m) {\n            if (Math::GMPz::Rmpz_tstbit($A[$row], $col)) {\n                $npivot = $row;\n                $nrow++;\n                last;\n            }\n        }\n\n        next if ($npivot == -1);\n\n        if ($npivot != $nrow) {\n            @A[$npivot, $nrow] = @A[$nrow, $npivot];\n            @I[$npivot, $nrow] = @I[$nrow, $npivot];\n        }\n\n        foreach my $row ($nrow + 1 .. $m) {\n            if (Math::GMPz::Rmpz_tstbit($A[$row], $col)) {\n                $A[$row] ^= $A[$nrow];\n                $I[$row] ^= $I[$nrow];\n            }\n        }\n    }\n\n    return (\\@A, \\@I);\n}\n\nsub is_smooth_over_prod ($n, $k) {\n\n    state $g = Math::GMPz::Rmpz_init_nobless();\n    state $t = Math::GMPz::Rmpz_init_nobless();\n\n    Math::GMPz::Rmpz_set($t, $n);\n    Math::GMPz::Rmpz_gcd($g, $t, $k);\n\n    while (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {\n        Math::GMPz::Rmpz_remove($t, $t, $g);\n        return 1 if Math::GMPz::Rmpz_cmpabs_ui($t, 1) == 0;\n        Math::GMPz::Rmpz_gcd($g, $t, $g);\n    }\n\n    return 0;\n}\n\nsub check_factor ($n, $g, $factors) {\n\n    while ($n % $g == 0) {\n\n        $n /= $g;\n        push @$factors, $g;\n\n        if (is_prime($n)) {\n            push @$factors, $n;\n            return 1;\n        }\n    }\n\n    return $n;\n}\n\nsub next_multiplier ($k) {\n\n    $k += 2;\n\n    until (is_square_free($k)) {\n        ++$k;\n    }\n\n    return $k;\n}\n\nsub cffm ($n, $verbose = 0, $multiplier = 1) {\n\n    local $| = 1;\n\n    # Check for primes and negative numbers\n    return ()   if $n <= 1;\n    return ($n) if is_prime($n);\n\n    # Check for perfect powers\n    if (my $k = is_power($n)) {\n        my @factors = __SUB__->(Math::GMPz->new(rootint($n, $k)), $verbose);\n        return sort { $a <=> $b } ((@factors) x $k);\n    }\n\n    my $N = $n * $multiplier;\n\n    my $x = Math::GMPz::Rmpz_init();\n    my $y = Math::GMPz::Rmpz_init();\n    my $z = Math::GMPz::Rmpz_init_set_ui(1);\n\n    my $w = Math::GMPz::Rmpz_init();\n    my $r = Math::GMPz::Rmpz_init();\n\n    Math::GMPz::Rmpz_sqrt($x, $N);\n    Math::GMPz::Rmpz_set($y, $x);\n\n    Math::GMPz::Rmpz_add($w, $x, $x);\n    Math::GMPz::Rmpz_set($r, $w);\n\n    my $f2 = Math::GMPz::Rmpz_init_set($x);\n    my $f1 = Math::GMPz::Rmpz_init_set_ui(1);\n\n    my (@A, @Q);\n\n    my $B  = int(exp(sqrt(log(\"$n\") * log(log(\"$n\"))) / 2));                      # B-smooth limit\n    my $nf = int(exp(sqrt(log(\"$n\") * log(log(\"$n\"))))**(sqrt(2) / 4) / 1.25);    # number of primes in factor-base\n\n    my @factor_base = (2);\n\n#<<<\n    if (B_SMOOTH_METHOD) {\n        forprimes {\n            if (Math::GMPz::Rmpz_kronecker_ui($N, $_) >= 0) {\n                push @factor_base, $_;\n            }\n        } 3, $B;\n    }\n    else {\n        for (my $p = 3 ; @factor_base < $nf ; $p = next_prime($p)) {\n            if (Math::GMPz::Rmpz_kronecker_ui($N, $p) >= 0) {\n                push @factor_base, $p;\n            }\n        }\n    }\n#>>>\n\n    my %factor_index;\n    @factor_index{@factor_base} = (0 .. $#factor_base);\n\n    my $exponents_signature = sub (@factors) {\n        my $sig = Math::GMPz::Rmpz_init_set_ui(0);\n\n        foreach my $p (@factors) {\n            if ($p->[1] & 1) {\n                Math::GMPz::Rmpz_setbit($sig, $factor_index{$p->[0]});\n            }\n        }\n\n        return $sig;\n    };\n\n    my $L  = scalar(@factor_base) + 1;                 # maximum number of matrix-rows\n    my $FP = Math::GMPz->new(vecprod(@factor_base));\n\n    if ($verbose) {\n        printf(\"[*] Factoring %s (%s digits)...\\n\\n\", \"$n\", length(\"$n\"));\n        say \"*** Step 1/2: Finding smooth relations ***\";\n        printf(\"Target: %s relations, with B = %s\\n\", $L, $factor_base[-1]);\n    }\n\n    my $t = Math::GMPz::Rmpz_init();\n\n    while (@A < $L) {\n\n        # y = r*z - y\n        Math::GMPz::Rmpz_mul($t, $r, $z);\n        Math::GMPz::Rmpz_sub($y, $t, $y);\n\n        # z = (n - y*y) / z\n        Math::GMPz::Rmpz_mul($t, $y, $y);\n        Math::GMPz::Rmpz_sub($t, $N, $t);\n        Math::GMPz::Rmpz_divexact($z, $t, $z);\n\n        # r = (x + y) / z\n        Math::GMPz::Rmpz_add($t, $x, $y);\n\n        if (ROUND_DIVISION) {\n\n            # Round (x+y)/z to nearest integer\n            Math::GMPz::Rmpz_set($r, $z);\n            Math::GMPz::Rmpz_addmul_ui($r, $t, 2);\n            Math::GMPz::Rmpz_div($r, $r, $z);\n            Math::GMPz::Rmpz_div_2exp($r, $r, 1);\n        }\n        else {\n\n            # Floor division: floor((x+y)/z)\n            Math::GMPz::Rmpz_div($r, $t, $z);\n        }\n\n        # f1 = (f1 + r*f2) % n\n        Math::GMPz::Rmpz_addmul($f1, $f2, $r);\n        Math::GMPz::Rmpz_mod($f1, $f1, $n);\n\n        # swap f1 with f2\n        ($f1, $f2) = ($f2, $f1);\n\n#<<<\n        if (Math::GMPz::Rmpz_perfect_square_p($z)) {\n            my $g = Math::GMPz->new(gcd($f1 - Math::GMPz->new(sqrtint($z)), $n));\n\n            if ($g > 1 and $g < $n) {\n                return sort { $a <=> $b } (\n                    __SUB__->($g, $verbose),\n                    __SUB__->($n / $g, $verbose)\n                );\n            }\n        }\n#>>>\n\n        if (is_smooth_over_prod($z, $FP)) {\n\n            my $abs_z   = abs($z);\n            my @factors = factor_exp($abs_z);\n\n            if (@factors) {\n                push @A, $exponents_signature->(@factors);\n                push @Q, [map { Math::GMPz::Rmpz_init_set($_) } ($f1, $abs_z)];\n            }\n\n            if ($verbose) {\n                printf(\"Progress: %d/%d relations.\\r\", scalar(@A), $L);\n            }\n        }\n\n        if (Math::GMPz::Rmpz_cmpabs_ui($z, 1) == 0) {\n\n            my $k = next_multiplier($multiplier);\n\n            say \"Trying again with multiplier k = $k\\n\" if $verbose;\n            return __SUB__->($n, $verbose, $k);\n        }\n    }\n\n    if ($verbose) {\n        say \"\\n\\n*** Step 2/2: Linear Algebra ***\";\n        say \"Performing Gaussian elimination...\";\n    }\n\n    if (@A < $L) {\n        push @A, map { Math::GMPz::Rmpz_init_set_ui(0) } 1 .. ($L - @A + 1);\n    }\n\n    my ($A, $I) = gaussian_elimination(\\@A, $L - 1);\n\n    my $LR = ((first { $A->[-$_] } 1 .. @$A) // 0) - 1;\n\n    if ($verbose) {\n        say \"Found $LR linear dependencies...\";\n        say \"Finding factors from congruences of squares...\\n\";\n    }\n\n    my @factors;\n    my $rem = $n;\n\n  SOLUTIONS: foreach my $solution (@{$I}[@$I - $LR .. $#$I]) {\n\n        my $X = 1;\n        my $Y = 1;\n\n        foreach my $i (0 .. $#Q) {\n\n            Math::GMPz::Rmpz_tstbit($solution, $i) || next;\n\n            ($X *= $Q[$i][0]) %= $n;\n            ($Y *= $Q[$i][1]);\n\n            my $g = Math::GMPz->new(gcd($X - Math::GMPz->new(sqrtint($Y)), $rem));\n\n            if ($g > 1 and $g < $rem) {\n                if ($verbose) {\n                    say \"`-> found factor: $g\";\n                }\n                $rem = check_factor($rem, $g, \\@factors);\n                last SOLUTIONS if $rem == 1;\n            }\n        }\n    }\n\n    say '' if $verbose;\n\n    my @final_factors;\n\n    foreach my $f (@factors) {\n        if (is_prime($f)) {\n            push @final_factors, $f;\n        }\n        else {\n            push @final_factors, __SUB__->($f, $verbose);\n        }\n    }\n\n    if ($rem != 1) {\n        if ($rem != $n) {\n            push @final_factors, __SUB__->($rem, $verbose);\n        }\n        else {\n            push @final_factors, $rem;\n        }\n    }\n\n    # Failed to factorize n (try again with a multiplier)\n    if ($rem == $n) {\n        my $k = next_multiplier($multiplier);\n        say \"Trying again with multiplier k = $k\\n\" if $verbose;\n        return __SUB__->($n, $verbose, $k);\n    }\n\n    # Return all the prime factors of n\n    return sort { $a <=> $b } @final_factors;\n}\n\nmy @composites = (\n    @ARGV ? (map { Math::GMPz->new($_) } @ARGV) : do {\n        map { Math::GMPz->new(urandomb($_)) + 2 } 2 .. 70;\n    }\n);\n\n# Run some tests when no argument is provided\nforeach my $n (@composites) {\n\n    my @f = cffm($n, @ARGV ? 1 : 0);\n\n    say \"$n = \", join(' * ', map { is_prime($_) ? $_ : \"$_ (composite)\" } @f);\n    die 'error' if Math::GMPz->new(vecprod(@f)) != $n;\n}\n"
  },
  {
    "path": "Math/continued_fractions.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 04 November 2015\n# Website: https://github.com/trizen\n\n# Continued fractions\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nno warnings 'recursion';\n\nsub root2 {\n    my ($n) = @_;\n\n    return 0 if $n <= 0;\n\n    1.0/(\n        2.0 + root2($n-1)\n    )\n}\n\nsub e {\n    my($i, $n) = @_;\n\n    return 0 if $n >= $i;\n\n    1.0/(\n        1.0 + 1.0/(\n            2.0*$n + 1.0/(\n                1.0 + e($i, $n+1)\n            )\n        )\n    )\n}\n\nsay 1+root2(100);       # sqrt(2)\nsay 2+e(100, 1);        # e\n"
  },
  {
    "path": "Math/continued_fractions_for_e.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 10 May 2016\n# Edit: 14 July 2017\n# Website: https://github.com/trizen\n\n# Continued fractions for the \"e\" mathematical constant.\n\nuse 5.010;\nuse strict;\n\nsub e_1 {\n    my ($i, $limit) = @_;\n    $limit > 0 ? ($i / ($i + e_1($i + 1, $limit - 1))) : 0;\n}\n\nsub e_2 {\n    my ($i, $limit) = @_;\n    $limit > 0 ? 1 / (1 + 1 / (2 * $i + 1 / (1 + e_2($i + 1, $limit - 1)))) : 0;\n}\n\nsub e_3 {\n    my ($i, $limit) = @_;\n    $limit > 0 ? (1 / (2 * $i + 1 + e_3($i + 1, $limit - 1))) : 0;\n}\n\nsub e_4 {\n    my ($i, $n) = @_;\n\n    return 0 if $n >= $i;\n\n    1 / (\n        1 + 1 / (\n            1 + 1 / (\n                (3 * $n) + 1 / (\n                    (12 * $n + 6) + 1 / (\n                        (3 * $n + 2) + e_4($i, $n + 1)\n                    )\n                )\n            )\n        )\n    );\n}\n\nsub e_5 {\n    my ($i, $n) = @_;\n\n    return 0 if $n >= $i;\n\n    1 / (\n        3 + 1 / (\n            2*$n + 1 / (\n                3 + 1 / (\n                    1 + 1 / (\n                        2*$n + 1 / (\n                            1 + e_5($i, $n + 1)\n                        )\n                    )\n                )\n            )\n        )\n    );\n}\n\nsub e_6 {\n    my ($i, $n) = @_;\n\n    return 0 if $n >= $i;\n\n    2 / (\n        8*($n+1) - 2 + 2 / (\n            4*($n+1) + 1 + e_6($i, $n+1)\n        )\n    );\n}\n\nsub e_7 {\n    my ($i, $n) = @_;\n\n    return 0 if $n >= $i;\n\n    8 / (\n        16*$n + 4 + 8 / (\n            8*($n+1) - 2 + e_7($i, $n+1)\n        )\n    );\n}\n\nsub e_8 {\n    my ($i, $n) = @_;\n\n    return 0 if $n >= $i;\n\n    1 / (\n        4*($n-1) + 1 + 1 / (\n            1 + 1/(\n                1 + e_8($i, $n+1)\n            )\n        )\n    );\n}\n\nsub e_9 {\n    my ($i, $n) = @_;\n\n    return 0 if $n >= $i;\n\n    1/(\n        2 + 1/(\n            4*$n + 1 + 1/(\n                -2 + 1/ (\n                    -4*$n - 3 + e_9($i, $n+1)\n                )\n            )\n        )\n    )\n}\n\nmy $r = 100;        # number of repetitions\n\nsay 1 + 1 / e_1(1, $r);                  # good convergence\nsay 2 + e_2(1, $r);                      # very fast convergence\nsay sqrt(1 + 2 / e_3(1, $r));            # very fast convergence\nsay sqrt(7 + 1 / (2 + (e_4($r, 1))));    # extremely fast convergence (best)\nsay ((5 + 1/(2 +  e_5($r, 1)))/2);       # extremely fast convergence\nsay sqrt(7 + 2/(5 + e_6($r, 1)));        # extremely fast convergence\nsay sqrt(7 + e_7($r, 1));                # very fast convergence\nsay ((1 + e_8($r, 1))**2);               # very fast convergence\nsay 3 + 1/(-4 + e_9($r, 1));             # extremely fast convergence\n"
  },
  {
    "path": "Math/continued_fractions_for_nth_roots.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 03 February 2019\n# https://github.com/trizen\n\n# Approximate n-th roots, using continued fractions.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Generalized_continued_fraction#Roots_of_positive_numbers\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload irootrem);\n\nsub cfrac_nth_root ($z, $m, $n, $y, $r, $k = 1) {\n\n    return 0 if ($r <= 0);\n\n    ($k**2 * $n**2 - $m**2) * $y**2 / (\n        (2 * $k + 1) * $n * (2 * $z - $y) - __SUB__->($z, $m, $n, $y, $r - 1, $k + 1)\n    );\n}\n\nsub nth_root ($z, $n, $r = 98) {\n    my ($x, $y) = irootrem($z, $n);         # express z as x^n + y\n\n    my $m = 1;\n    my $t = cfrac_nth_root($z, $m, $n, $y, $r);\n\n    $x**$m + ((2 * $x * $m * $y) / ($n * (2 * $z - $y) - $m * $y - $t));\n}\n\nsay nth_root(1234,   2)->as_dec;    #=> 35.1283361405005916058703116253563067645404854788\nsay nth_root(12345,  3)->as_dec;    #=> 23.1116187498072686808719733295882901745171370026\nsay nth_root(123456, 5)->as_dec;    #=> 10.4304354640976648337531700856866384705501389373\n\nsay \"\\n=> Approximations to 2^(1/3):\";\n\nforeach my $k (1 .. 10) {\n    say \"   2^(1/3) =~ \", nth_root(2, 3, $k);\n}\n\n__END__\n=> Approximations to 2^(1/3):\n   2^(1/3) =~ 131/104\n   2^(1/3) =~ 286/227\n   2^(1/3) =~ 17494/13885\n   2^(1/3) =~ 49147/39008\n   2^(1/3) =~ 4725601/3750712\n   2^(1/3) =~ 12205019/9687130\n   2^(1/3) =~ 320084311/254051086\n   2^(1/3) =~ 1829589323/1452146008\n   2^(1/3) =~ 60779482705/48240707392\n   2^(1/3) =~ 410233899668/325602861943\n"
  },
  {
    "path": "Math/continued_fractions_for_pi.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 10 May 2016\n# Website: https://github.com/trizen\n\n# Continued fractions for PI.\n# Inspired by: https://www.youtube.com/watch?v=fd39yK2GZSA\n\nuse 5.010;\nuse strict;\n\nsub pi_1 {\n    my ($i, $limit) = @_;\n    $limit > 0 ? ($i**2 / (2 + pi_1($i + 2, $limit - 1))) : 0;\n}\n\nsub pi_2 {\n    my ($i, $limit) = @_;\n    $limit > 0 ? ($i**2 / (2 * $i + 1 + pi_2($i + 1, $limit - 1))) : 0;\n}\n\nsub pi_3 {\n    my ($i, $limit) = @_;\n    $limit > 0 ? ((2 * $i + 1)**2 / (6 + pi_3($i + 1, $limit - 1))) : 0;\n}\n\nsay 4 / (1 + pi_1(1, 100000));    # slow convergence\nsay 4 / (1 + pi_2(1, 100));       # fast convergence\nsay 3 + pi_3(0, 100000);          # slow convergence\n"
  },
  {
    "path": "Math/continued_fractions_for_square_roots.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 09 November 2015\n# https://github.com/trizen\n\n# Square roots as continued fractions\n\n# See also:\n#   https://en.wikipedia.org/wiki/Continued_fraction#Generalized_continued_fraction_for_square_roots\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nno warnings 'recursion';\n\nsub square_root {\n    my ($n, $precision) = @_;\n    $precision > 0 ? ($n - 1) / (2 + square_root($n, $precision - 1)) : 0;\n}\n\nfor my $i (1 .. 10) {\n    printf(\"sqrt(%2d) = %s\\n\", $i, 1 + square_root($i, 1000));\n}\n"
  },
  {
    "path": "Math/continued_fractions_prime_constant.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 10 May 2016\n# Website: https://github.com/trizen\n\n# Continued fraction constant for primes.\n\nuse 5.010;\nuse strict;\nuse ntheory qw(nth_prime);\n\nsub prime_constant {\n    my ($i, $limit) = @_;\n    my $p = nth_prime($i);\n    $limit > 0 ? ($p / ($p + prime_constant($i + 1, $limit - 1))) : 0;\n}\n\nmy $pc = prime_constant(1, 10000);\n\nsay $pc;\nsay 1 / (1 + $pc);    # \"1\" is considered prime here\n\n__END__\n0.71961651193526\n0.581525004592215\n"
  },
  {
    "path": "Math/convergent_series.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 31 July 2015\n# Website: https://github.com/trizen\n\n# A simple generator of convergent infinite series.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse List::Util qw(first);\nuse Term::ReadLine qw();\nuse Storable qw(store retrieve);\n\nmy $db = 'convergent_series.db';\n\nmy %map;\nif (-e $db) {\n    %map = %{retrieve($db)};\n}\nelse {\n    generate_all();\n    save_database();\n}\n\nsub save_database {\n    store(\\%map, 'convergent_series.db');\n}\n\n#\n## sum(i^k / (j*n)^l)\n#\nsub generate_squared_series {\n\n    my $ref = \\%map;\n\n    my %f;\n    foreach my $i (1 .. 4) {\n        foreach my $j (1 .. 4) {\n            foreach my $k (1 .. 3) {\n                foreach my $l (2 .. 3) {\n\n                    my $sum = 0;\n                    foreach my $n (1 .. 10000000) {\n                        $sum += $i**$k / ($j * $n)**$l;\n                    }\n\n                    my $formula = \"sum($i**$k/($j*n)**$l)\";\n\n                    $formula =~ s/\\b1\\*(?=[\\d(n])//g;\n                    $formula =~ s/[\\d)]\\K\\*\\*1\\b//g;\n                    $formula =~ s/\\b1\\K\\*\\*\\d+//g;\n                    $formula =~ s{/1\\b}{}g;\n                    $formula =~ s/\\((\\d+|n)\\)/$1/g;\n\n                    my $form = ($f{$formula} //= \\$formula);\n\n                    $ref = \\%map;\n                    say \"$formula ($sum)\";\n\n                    foreach my $char (split(//, $sum)) {\n                        if (not defined first { $formula eq ${$_} } @{$ref->{f}}) {\n                            push @{$ref->{f}}, $form;\n                        }\n                        $ref = ($ref->{d}{$char} //= {});\n                    }\n\n                }\n            }\n        }\n    }\n}\n\nsub generate_all {\n    generate_squared_series();\n\n    # more to come...\n\n    print \"\\n** Database generated successfully!\\n\\n\";\n}\n\nsub lookup {\n    my ($n) = @_;\n\n    my %found;\n    foreach my $i (2 .. 100) {\n\n        foreach my $pair ([$n, \"\"],\n                          [$n**(1 / $i),    \"**$i\"],\n                          [$n**$i,          \"**(1/$i)\"],\n                          [$n**(-($i - 1)), \"**(-${\\($i-1)})\"],\n                          [$n / $i,         \"*$i\"],\n                          [$n * $i,         \"/$i\"],\n                          (map { [$n**$i / $_, \"*$_)**(1/$i)\"] } 2 .. 9)) {\n\n            my $j = $pair->[0];\n            my @chars = split(//, $j);\n\n            my $max = 0;\n            my $ref = \\%map;\n\n            my @match;\n            while (@chars and exists($ref->{d}{$chars[0]})) {\n                my $char = shift @chars;\n                $ref = $ref->{d}{$char};\n                push @match, $char;\n                ++$max;\n            }\n\n            if ($max >= 6) {\n                push @{$found{$max}}, [$ref->{f}, $pair->[1], join('', @match)];\n            }\n        }\n    }\n\n    my @matches;\n    foreach my $key (sort { $b <=> $a } keys %found) {\n        my $arrs = $found{$key};\n\n        my %seen;\n        foreach my $arr (@{$arrs}) {\n            foreach my $f (@{$arr->[0]}) {\n\n                my $func = \"${$f}$arr->[1]\";\n                if (($func =~ tr/)//) != ($func =~ tr/(//)) {\n                    $func = \"($func\";\n                }\n\n                next if $seen{$func}++;\n                push @matches, sprintf(\"%-50s%s\", $func, \"($arr->[2])\");\n            }\n        }\n    }\n    return @matches;\n}\n\nmy %const = (\n             e  => exp(1),\n             pi => atan2(0, -'inf'),\n            );\n\nmy $term = Term::ReadLine->new(\"Convergent series\");\nwhile (defined(my $expr = $term->readline(\"Enter an expression: \"))) {\n\n    {\n        local $\" = '|';\n        $expr =~ s/\\b(@{[keys %const]})\\b/$const{$1}/g;\n    }\n\n    my $n = eval($expr);\n\n    if ($@) {\n        warn \"\\n[!] Invalid expression: $expr\\n\\t$@\\n\";\n        next;\n    }\n    elsif (not defined($n)) {\n        next;\n    }\n\n    my @formulas = lookup($n);\n\n    if (@formulas) {\n        print \"\\n[+] Found the following formulas for $n:\\n\\t\";\n        print join(\"\\n\\t\", @formulas), \"\\n\\n\";\n    }\n    else {\n        print \"\\n[-] Can't find any formula for $n\\n\\n\";\n    }\n}\n\n__END__\n\nuse 5.010;\nuse strict;\n\nsub pi {\n    my $sum = 0;\n\n    for my $k(0..10) {\n        $sum += (1/16**$k) * (4/(8*$k+1) - 2/(8*$k+4) - 1/(8*$k+5) - 1/(8*$k+6));\n    }\n\n    $sum;\n}\n\nsub zeta {\n    my ($n) = @_;\n\n    my $sum = 0;\n    for my $i(1..100000) {\n        $sum += 1/$i**$i;\n    }\n\n    $sum;\n}\n\nsay zeta(2);\nsay pi();\n"
  },
  {
    "path": "Math/cosmic_calendar.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 04 April 2014\n# https://trizenx.blogspot.com\n\n# Inspired from: Cosmos.A.Space.Time.Odyssey.S01E01\n#                            by Neil deGrasse Tyson\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Term::ReadLine;\n\n# Here is the definition of the cosmic year\nmy @cosmic_year = [(13.798 + [+0.037, -0.037]->[rand 2]) * 10**9, 'years'];\n\npush @cosmic_year, [$cosmic_year[-1][0] / 12,         'months'];\npush @cosmic_year, [$cosmic_year[-1][0] / 30.4368499, 'days'];\npush @cosmic_year, [$cosmic_year[-1][0] / 24,         'hours'];\npush @cosmic_year, [$cosmic_year[-1][0] / 60,         'minutes'];\npush @cosmic_year, [$cosmic_year[-1][0] / 60,         'seconds'];\npush @cosmic_year, [$cosmic_year[-1][0] / 1000,       'milliseconds'];\n\nprint <<'EOF';\nThis program will scale the age of the universe to a normal year.\n\nYou can insert any number you want, and the program will map it\ninto this cosmic year to have a feeling how long ago it was,\ncompared to the age of the universe.\n\nEOF\n\nsub output {\n    my ($value, $type) = @_;\n    printf \"\\n=> In the cosmic scale, that happened about %.2f %s ago!\\n\\n\", $value, $type;\n}\n\nBLOCK: {\n    my $term  = Term::ReadLine->new('Cosmic Calendar');\n    my $value = eval $term->readline(\"How long ago? (any expression, in years): \");\n\n    foreach my $bit (@cosmic_year) {\n        $value >= $bit->[0]\n            && output($value / $bit->[0], $bit->[1])\n            && redo BLOCK;\n    }\n\n    warn \"\\n[!] Your value `$value' is too small, compared to the Cosmic Calendar!\\n\\n\";\n    redo;\n}\n"
  },
  {
    "path": "Math/count_of_brilliant_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Count the number of Brilliant numbers < 10^n.\n\n# Brilliant numbers are semiprimes such that both prime factors have the same number of digits in base 10.\n\n# OEIS sequence:\n#   https://oeis.org/A086846 --  Number of brilliant numbers < 10^n.\n\n# See also:\n#   https://rosettacode.org/wiki/Brilliant_numbers\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub brilliant_numbers_count_fast ($n) {\n\n    my $count = 0;\n    my $len   = length(sqrtint($n));\n\n    foreach my $k (1 .. $len - 1) {\n        my $pi = prime_count(powint(10, $k - 1), powint(10, $k) - 1);\n        $count += binomial($pi, 2) + $pi;\n    }\n\n    my $min = powint(10, $len - 1);\n    my $max = powint(10, $len) - 1;\n\n    forprimes {\n        $count += prime_count($_, vecmin($max, divint($n, $_)));\n    } $min, $max;\n\n    return $count;\n}\n\nsub brilliant_numbers_count_faster ($n) {\n\n    my $count = 0;\n    my $len   = length(sqrtint($n));\n\n    foreach my $k (1 .. $len - 1) {\n        my $pi = prime_count(powint(10, $k - 1), powint(10, $k) - 1);\n        $count += binomial($pi, 2) + $pi;\n    }\n\n    my $min = powint(10, $len - 1);\n    my $max = powint(10, $len) - 1;\n\n    my $pi_min = prime_count($min);\n    my $pi_max = prime_count($max);\n\n    my $j = -1;\n\n    forprimes {\n        if ($_ * $_ <= $n) {\n            $count += (($n >= $_ * $max) ? $pi_max : prime_count(divint($n, $_))) - $pi_min - ++$j;\n        }\n        else {\n            lastfor;\n        }\n    } $min, $max;\n\n    return $count;\n}\n\nsub brilliant_numbers_count_slow ($n) {\n\n    my $count = 0;\n    my $len   = length(sqrtint($n));\n\n    foreach my $k (1 .. $len - 1) {\n        my $pi = prime_count(10**($k - 1), 10**$k - 1);\n        $count += binomial($pi, 2) + $pi;\n    }\n\n    my $P = primes(10**($len - 1), 10**$len - 1);\n\n    foreach my $i (0 .. $#{$P}) {\n        foreach my $j ($i .. $#{$P}) {\n            $P->[$i] * $P->[$j] > $n ? last : ++$count;\n        }\n    }\n\n    return $count;\n}\n\nforeach my $n (1 .. 12) {\n    my $v = powint(10, $n) - 1;\n    printf(\"Less than 10^%s, there are %s brilliant numbers\\n\", $n, brilliant_numbers_count_faster($v));\n}\n\n__END__\nLess than 10^1, there are 3 brilliant numbers\nLess than 10^2, there are 10 brilliant numbers\nLess than 10^3, there are 73 brilliant numbers\nLess than 10^4, there are 241 brilliant numbers\nLess than 10^5, there are 2504 brilliant numbers\nLess than 10^6, there are 10537 brilliant numbers\nLess than 10^7, there are 124363 brilliant numbers\nLess than 10^8, there are 573928 brilliant numbers\nLess than 10^9, there are 7407840 brilliant numbers\nLess than 10^10, there are 35547994 brilliant numbers\nLess than 10^11, there are 491316166 brilliant numbers\nLess than 10^12, there are 2409600865 brilliant numbers\nLess than 10^13, there are 34896253009 brilliant numbers\nLess than 10^14, there are 174155363186 brilliant numbers\nLess than 10^15, there are 2601913448896 brilliant numbers\nLess than 10^16, there are 13163230391312 brilliant numbers\n"
  },
  {
    "path": "Math/count_of_cube-full_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Fast algorithm for counting the number of cube-full numbers <= n.\n# A positive integer n is considered cube-full, if for every prime p that divides n, so does p^3.\n\n# See also:\n#   THE DISTRIBUTION OF CUBE-FULL NUMBERS, by P. SHIU (1990).\n\n# OEIS:\n#   https://oeis.org/A036966 -- 3-full (or cube-full, or cubefull) numbers: if a prime p divides n then so does p^3.\n\nuse 5.020;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub cubefull_count($n) {\n    my $total = 0;\n\n    for my $a (1 .. rootint($n, 5)) {\n        is_square_free($a) || next;\n        for my $b (1 .. rootint(divint($n, powint($a, 5)), 4)) {\n            gcd($a, $b) == 1 or next;\n            is_square_free($b) || next;\n            my $t = mulint(powint($a, 5), powint($b, 4));\n            $total += rootint(divint($n, $t), 3);\n        }\n    }\n\n    return $total;\n}\n\nforeach my $n (1 .. 20) {\n    say \"C_3(10^$n) = \", cubefull_count(powint(10, $n));\n}\n\n__END__\nC_3(10^1) = 2\nC_3(10^2) = 7\nC_3(10^3) = 20\nC_3(10^4) = 51\nC_3(10^5) = 129\nC_3(10^6) = 307\nC_3(10^7) = 713\nC_3(10^8) = 1645\nC_3(10^9) = 3721\nC_3(10^10) = 8348\nC_3(10^11) = 18589\nC_3(10^12) = 41136\nC_3(10^13) = 90619\nC_3(10^14) = 198767\nC_3(10^15) = 434572\nC_3(10^16) = 947753\nC_3(10^17) = 2062437\nC_3(10^18) = 4480253\nC_3(10^19) = 9718457\nC_3(10^20) = 21055958\n"
  },
  {
    "path": "Math/count_of_integers_with_gpf_of_n_equals_p.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 15 March 2020\n# https://github.com/trizen\n\n# Given `n` and `p`, count the number of integers k <= n, such that:\n#    gpf(k) = p\n# where `gpf(k)` is the greatest prime factor of k.\n\n# This is equivalent with the number of p-smooth numbers <= floor(n/p).\n\n# See also:\n#   https://en.wikipedia.org/wiki/Smooth_number\n\nuse 5.020;\nuse integer;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub count_with_gpf ($n, $p) {\n    smooth_count($n/$p, $p);\n}\n\nforeach my $n (1 .. 10) {\n    say \"a(10^$n) for primes below 20: {\", join(', ', map { count_with_gpf(powint(10, $n), $_) } @{primes(20)}), \"}\";\n}\n\n__END__\na(10^1)  for primes below 20: {3, 3, 2, 1, 0, 0, 0, 0}\na(10^2)  for primes below 20: {6, 13, 14, 12, 9, 7, 5, 5}\na(10^3)  for primes below 20: {9, 30, 46, 55, 51, 50, 45, 44}\na(10^4)  for primes below 20: {13, 53, 108, 163, 184, 211, 212, 224}\na(10^5)  for primes below 20: {16, 84, 212, 381, 503, 651, 731, 840}\na(10^6)  for primes below 20: {19, 122, 365, 766, 1159, 1674, 2073, 2572}\na(10^7)  for primes below 20: {23, 166, 578, 1387, 2365, 3769, 5100, 6809}\na(10^8)  for primes below 20: {26, 217, 861, 2322, 4411, 7681, 11290, 16141}\na(10^9)  for primes below 20: {29, 276, 1224, 3664, 7673, 14498, 22986, 35060}\na(10^10) for primes below 20: {33, 342, 1677, 5522, 12618, 25721, 43765, 70947}\n"
  },
  {
    "path": "Math/count_of_integers_with_lpf_of_n_equals_p.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 15 March 2020\n# https://github.com/trizen\n\n# Given `n` and `p`, count the number of integers k <= n, such that:\n#    lpf(k) = p\n# where `lpf(k)` is the least prime factor of k.\n\n# This is equivalent with the number of p-rough numbers <= floor(n/p).\n\n# See also:\n#   https://en.wikipedia.org/wiki/Rough_number\n\nuse 5.020;\nuse integer;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub count_with_lpf ($n, $p) {\n\n    #~ return rough_count($n/$p, $p);\n\n    if ($p > sqrt($n)) {\n        return 1;\n    }\n\n    my $u = 0;\n    my $t = $n / $p;\n\n    for (my $q = 2 ; $q < $p ; $q = next_prime($q)) {\n\n        my $v = __SUB__->($t - ($t % $q), $q);\n\n        if ($v == 1) {\n            $u += prime_count($q, $p - 1);\n            last;\n        }\n        else {\n            $u += $v;\n        }\n    }\n\n    $t - $u;\n}\n\nforeach my $n (1 .. 10) {\n    say \"a(10^$n) for primes below 20: {\", join(', ', map { count_with_lpf(powint(10, $n), $_) } @{primes(20)}), \"}\";\n}\n\n__END__\na(10^1)  for primes below 20: {5, 2, 1, 1, 1, 1, 1, 1}\na(10^2)  for primes below 20: {50, 17, 7, 4, 1, 1, 1, 1}\na(10^3)  for primes below 20: {500, 167, 67, 38, 21, 17, 11, 9}\na(10^4)  for primes below 20: {5000, 1667, 667, 381, 208, 160, 111, 95}\na(10^5)  for primes below 20: {50000, 16667, 6667, 3809, 2078, 1598, 1128, 950}\na(10^6)  for primes below 20: {500000, 166667, 66667, 38095, 20779, 15984, 11284, 9503}\na(10^7)  for primes below 20: {5000000, 1666667, 666667, 380953, 207792, 159840, 112830, 95017}\na(10^8)  for primes below 20: {50000000, 16666667, 6666667, 3809524, 2077921, 1598401, 1128285, 950134}\na(10^9)  for primes below 20: {500000000, 166666667, 66666667, 38095238, 20779221, 15984017, 11282835, 9501332}\na(10^10) for primes below 20: {5000000000, 1666666667, 666666667, 380952381, 207792208, 159840160, 112828349, 95013344}\n"
  },
  {
    "path": "Math/count_of_inverse_tau_in_range.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 14 May 2026\n# https://github.com/trizen\n\n# Count the numbers in a given range [A,B] that have exactly `n` divisors.\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\n\nprime_precalc(1e7);\n\nsub unique_permutations($array, $callback) {\n    sub ($items, $current_perm) {\n\n        if (!@$items) {\n            $callback->($current_perm);\n            return;\n        }\n\n        my %level_seen;\n        for my $i (0 .. $#$items) {\n            my $item = $items->[$i];\n\n            # Skip iterations for duplicate elements in the same level\n            next if $level_seen{$item}++;\n\n            my @new_items = @$items;\n            splice(@new_items, $i, 1);\n\n            my @new_perm = (@$current_perm, $item);\n            __SUB__->(\\@new_items, \\@new_perm);\n        }\n    }->($array, []);\n}\n\nsub count_prime_signature_numbers($n, $prime_signature) {\n\n    my $k = scalar(@$prime_signature);\n\n    if ($k == 0) {\n        return 1 if (1 <= $n);\n        return 0;\n    }\n\n    $n >= 1 || return 0;\n\n    my $count = 0;\n\n    my $generate = sub ($m, $lo, $k, $P, $sum_e, $j = 0) {\n\n        my $e  = $P->[$k - 1];\n        my $hi = rootint(divint($n, $m), $sum_e);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        if ($k == 1) {\n            $count += prime_count($hi) - $j;\n            return;\n        }\n\n        if ($k == 2) {\n            my $e2 = $P->[0];\n            foreach my $p (@{primes($lo, $hi)}) {\n                my $t = mulint($m, powint($p, $e));\n                my $u = rootint(divint($n, $t), $e2);\n                $count += prime_count($u) - ++$j;\n            }\n            return;\n        }\n\n        for (my $p = $lo ; $p <= $hi ;) {\n            my $t = mulint($m, powint($p, $e));\n            my $r = next_prime($p);\n            __SUB__->($t, $r, $k - 1, $P, $sum_e - $e, ++$j);\n            $p = $r;\n        }\n    };\n\n    my $sum_e = vecsum(@$prime_signature) || return 0;\n\n    if ($sum_e > logint($n, 2)) {\n        return 0;\n    }\n\n    unique_permutations(\n        $prime_signature,\n        sub ($perm) {\n            $generate->(1, 2, scalar(@$perm), $perm, $sum_e);\n        }\n    );\n\n    return $count;\n}\n\nsub count_prime_signature_numbers_in_range($A, $B, $signature) {\n    my $term_1 = count_prime_signature_numbers($A - 1, $signature);\n    my $term_2 = count_prime_signature_numbers($B,     $signature);\n    $term_2 - $term_1;\n}\n\nsub multiplicative_partitions($n, $max_value = $n) {\n\n    my @results;\n    my @divs = divisors($n);\n\n    shift(@divs);    # remove divisor '1'\n\n    my $end = $#divs;\n    sub ($target, $min_idx, $path) {\n\n        if ($target == 1) {\n            push @results, $path;\n            return;\n        }\n\n        for my $i ($min_idx .. $end) {\n            my $d = $divs[$i];\n\n            # Prune branch if the divisor exceeds the remaining target\n            last if $d > $target;\n            last if $d > $max_value;\n\n            if ($target % $d == 0) {\n                __SUB__->(divint($target, $d), $i, [@$path, $d]);\n            }\n        }\n    }->($n, 0, []);\n\n    return @results;\n}\n\nsub count_inverse_tau($A, $B, $n) {\n\n    my @signatures = map {\n        [map { $_ - 1 } @$_]\n    } multiplicative_partitions($n, logint($B, 2) + 1);\n\n    my @counts;\n    foreach my $sig (@signatures) {\n        push @counts, count_prime_signature_numbers_in_range($A, $B, $sig);\n    }\n\n    vecsum(@counts);\n}\n\ncount_inverse_tau(1, 462, 16) == 16 or die \"error\";\ncount_inverse_tau(1,   powint(2, 9),  10) == 13    or die \"error\";\ncount_inverse_tau(1,   powint(2, 40), 5040) == 103 or die \"error\";\ncount_inverse_tau(1e5, 1e5 + 500, 48) == 10 or die \"error\";\ncount_inverse_tau(100050, 100500, 48) == 10 or die \"error\";\n\n# Number of k <= 2^(n-1) such that tau(k) = n\n# https://oeis.org/A393179\nforeach my $n (1 .. 32) {\n    say \"a($n) = \", count_inverse_tau(1, powint(2, $n - 1), $n);\n}\n"
  },
  {
    "path": "Math/count_of_k-almost_primes.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 22 May 2020\n# https://github.com/trizen\n\n# Count the number of k-almost primes <= n.\n\n# Definition:\n#   A number is k-almost prime if it is the product of k prime numbers (not necessarily distinct).\n#   In other works, a number n is k-almost prime iff: bigomega(n) = k.\n\n# See also:\n#   https://mathworld.wolfram.com/AlmostPrime.html\n\n# OEIS:\n#   https://oeis.org/A072000 -- count of 2-almost primes\n#   https://oeis.org/A072114 -- count of 3-almost primes\n#   https://oeis.org/A082996 -- count of 4-almost primes\n#   https://oeis.org/A126280 -- Triangle read by rows: T(k,n) is number of numbers <= 10^n that are products of k primes.\n\nuse 5.036;\nuse ntheory qw(:all);\n\nsub k_prime_count ($n, $k) {\n\n    if ($k == 1) {\n        return prime_count($n);\n    }\n\n    if ($k == 2) {\n        return semiprime_count($n);\n    }\n\n    my $count = 0;\n\n    sub ($m, $p, $k, $j = 0) {\n\n        my $s = rootint(divint($n, $m), $k);\n\n        if ($k == 2) {\n\n            forprimes {\n                $count += prime_count(divint($n, mulint($m, $_))) - $j++;\n            } $p, $s;\n\n            return;\n        }\n\n        foreach my $q (@{primes($p, $s)}) {\n            __SUB__->($m * $q, $q, $k - 1, $j++);\n        }\n    }->(1, 2, $k);\n\n    return $count;\n}\n\n# Run some tests\n\nforeach my $k (1 .. 10) {\n\n    my $upto = pn_primorial($k) + int(rand(1e5));\n\n    my $x = k_prime_count($upto, $k);\n    my $y = almost_prime_count($k, $upto);\n\n    say \"Testing: $k with n = $upto -> $x\";\n\n    $x == $y\n      or die \"Error: $x != $y\";\n}\n\nsay '';\n\nforeach my $k (1 .. 10) {\n    printf(\"Count of %2d-almost primes <= 10^n: %s\\n\", $k, join(', ', map { k_prime_count(powint(10, $_), $k) } 0 .. 10));\n}\n\n__END__\nCount of  1-almost primes <= 10^n: 0, 4, 25, 168, 1229, 9592, 78498, 664579, 5761455, 50847534, 455052511\nCount of  2-almost primes <= 10^n: 0, 4, 34, 299, 2625, 23378, 210035, 1904324, 17427258, 160788536, 1493776443\nCount of  3-almost primes <= 10^n: 0, 1, 22, 247, 2569, 25556, 250853, 2444359, 23727305, 229924367, 2227121996\nCount of  4-almost primes <= 10^n: 0, 0, 12, 149, 1712, 18744, 198062, 2050696, 20959322, 212385942, 2139236881\nCount of  5-almost primes <= 10^n: 0, 0, 4, 76, 963, 11185, 124465, 1349779, 14371023, 150982388, 1570678136\nCount of  6-almost primes <= 10^n: 0, 0, 2, 37, 485, 5933, 68963, 774078, 8493366, 91683887, 977694273\nCount of  7-almost primes <= 10^n: 0, 0, 0, 14, 231, 2973, 35585, 409849, 4600247, 50678212, 550454756\nCount of  8-almost primes <= 10^n: 0, 0, 0, 7, 105, 1418, 17572, 207207, 2367507, 26483012, 291646797\nCount of  9-almost primes <= 10^n: 0, 0, 0, 2, 47, 671, 8491, 101787, 1180751, 13377156, 148930536\nCount of 10-almost primes <= 10^n: 0, 0, 0, 0, 22, 306, 4016, 49163, 578154, 6618221, 74342563\n"
  },
  {
    "path": "Math/count_of_k-omega_primes.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 14 March 2021\n# https://github.com/trizen\n\n# Count the number of k-omega primes <= n.\n\n# Definition:\n#   k-omega primes are numbers n such that omega(n) = k.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://en.wikipedia.org/wiki/Prime_omega_function\n\nuse 5.020;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub omega_prime_count_rec ($n, $k = 1) {\n\n    if ($k == 1) {\n        return prime_power_count($n);\n    }\n\n    my $count = 0;\n\n    sub ($m, $p, $k, $s = rootint(divint($n, $m), $k), $j = 1) {\n\n        if ($k == 2) {\n\n            for (; $p <= $s ; ++$j) {\n\n                my $r = next_prime($p);\n\n                for (my $t = mulint($m, $p) ; $t <= $n ; $t = mulint($t, $p)) {\n\n                    my $w = divint($n, $t);\n\n                    if ($r > $w) {\n                        last;\n                    }\n\n                    $count += prime_count($w) - $j;\n\n                    for (my $r2 = $r ; $r2 <= $w ; $r2 = next_prime($r2)) {\n\n                        my $u = vecprod($t, $r2, $r2);\n\n                        if ($u > $n) {\n                            last;\n                        }\n\n                        for (; $u <= $n ; $u = mulint($u, $r2)) {\n                            ++$count;\n                        }\n                    }\n                }\n\n                $p = $r;\n            }\n\n            return;\n        }\n\n        for (; $p <= $s ; ++$j) {\n\n            my $r = next_prime($p);\n\n            for (my $t = mulint($m, $p) ; $t <= $n ; $t = mulint($t, $p)) {\n                my $s = rootint(divint($n, $t), $k - 1);\n                last if ($r > $s);\n                __SUB__->($t, $r, $k - 1, $s, $j + 1);\n            }\n\n            $p = $r;\n        }\n    }->(1, 2, $k);\n\n    return $count;\n}\n\n# Run some tests\n\nforeach my $k (1 .. 10) {\n\n    my $upto = pn_primorial($k) + int(rand(1e5));\n\n    my $x = omega_prime_count_rec($upto, $k);\n    my $y = omega_prime_count($k, $upto);\n\n    say \"Testing: $k with n = $upto -> $x\";\n\n    $x == $y\n      or die \"Error: $x != $y\";\n}\n\nsay '';\n\nforeach my $k (1 .. 8) {\n    say(\"Count of $k-omega primes for 10^n: \", join(', ', map { omega_prime_count_rec(10**$_, $k) } 0 .. 8));\n}\n\n__END__\nCount of 1-omega primes for 10^n: 0, 7, 35, 193, 1280, 9700, 78734, 665134, 5762859\nCount of 2-omega primes for 10^n: 0, 2, 56, 508, 4097, 33759, 288726, 2536838, 22724609\nCount of 3-omega primes for 10^n: 0, 0, 8, 275, 3695, 38844, 379720, 3642766, 34800362\nCount of 4-omega primes for 10^n: 0, 0, 0, 23, 894, 15855, 208034, 2389433, 25789580\nCount of 5-omega primes for 10^n: 0, 0, 0, 0, 33, 1816, 42492, 691209, 9351293\nCount of 6-omega primes for 10^n: 0, 0, 0, 0, 0, 25, 2285, 72902, 1490458\nCount of 7-omega primes for 10^n: 0, 0, 0, 0, 0, 0, 8, 1716, 80119\nCount of 8-omega primes for 10^n: 0, 0, 0, 0, 0, 0, 0, 1, 719\n"
  },
  {
    "path": "Math/count_of_k-powerfree_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 20 August 2021\n# https://github.com/trizen\n\n# Sub-linear formula for computing the count of k-powerfree numbers <= n.\n\n# See also:\n#   https://oeis.org/A013928 -- Number of (positive) squarefree numbers < n.\n#   https://oeis.org/A060431 -- Number of cubefree numbers <= n.\n#   https://oeis.org/A071172 -- Number of squarefree integers <= 10^n.\n#   https://oeis.org/A160112 -- Number of cubefree integers not exceeding 10^n.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(vecall factor_exp powint divint forsquarefree rootint);\nuse experimental qw(signatures);\n\nsub is_powerfree ($n, $k = 2) {\n    (vecall { $_->[1] < $k } factor_exp($n)) ? 1 : 0;\n}\n\nsub powerfree_count ($n, $k = 2) {\n    my $count = 0;\n    forsquarefree {\n        $count += ((scalar(@_) & 1) ? -1 : 1) * divint($n, powint($_, $k));\n    } rootint($n, $k);\n    return $count;\n}\n\nforeach my $k (2 .. 10) {\n    printf(\"Number of %2d-powerfree numbers <= 10^j: {%s}\\n\", $k,\n           join(', ', map { powerfree_count(powint(10, $_), $k) } 0 .. 10));\n}\n\nuse Test::More tests => 10;\n\nforeach my $k (1..10) {\n    my $n = 100;\n\n    is_deeply(\n        [map { powerfree_count($_, $k) } 1..$n],\n        [map { scalar grep { is_powerfree($_, $k) } 1..$_ } 1..$n],\n    );\n}\n\n__END__\nNumber of  2-powerfree numbers <= 10^j: {1, 7, 61, 608, 6083, 60794, 607926, 6079291, 60792694, 607927124, 6079270942}\nNumber of  3-powerfree numbers <= 10^j: {1, 9, 85, 833, 8319, 83190, 831910, 8319081, 83190727, 831907372, 8319073719}\nNumber of  4-powerfree numbers <= 10^j: {1, 10, 93, 925, 9240, 92395, 923939, 9239385, 92393839, 923938406, 9239384029}\nNumber of  5-powerfree numbers <= 10^j: {1, 10, 97, 965, 9645, 96440, 964388, 9643874, 96438737, 964387341, 9643873409}\nNumber of  6-powerfree numbers <= 10^j: {1, 10, 99, 984, 9831, 98297, 982954, 9829527, 98295260, 982952591, 9829525925}\nNumber of  7-powerfree numbers <= 10^j: {1, 10, 100, 993, 9918, 99173, 991721, 9917199, 99171986, 991719856, 9917198560}\nNumber of  8-powerfree numbers <= 10^j: {1, 10, 100, 997, 9960, 99595, 995940, 9959393, 99593921, 995939202, 9959392012}\nNumber of  9-powerfree numbers <= 10^j: {1, 10, 100, 999, 9981, 99800, 997997, 9979956, 99799564, 997995634, 9979956329}\nNumber of 10-powerfree numbers <= 10^j: {1, 10, 100, 1000, 9991, 99902, 999008, 9990065, 99900642, 999006414, 9990064132}\n"
  },
  {
    "path": "Math/count_of_k-powerful_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 11 February 2020\n# https://github.com/trizen\n\n# Fast recursive algorithm for counting the number of k-powerful numbers <= n.\n# A positive integer n is considered k-powerful, if for every prime p that divides n, so does p^k.\n\n# Example:\n#   2-powerful = a^2 * b^3,             for a,b >= 1\n#   3-powerful = a^3 * b^4 * c^5,       for a,b,c >= 1\n#   4-powerful = a^4 * b^5 * c^6 * d^7, for a,b,c,d >= 1\n\n# OEIS:\n#   https://oeis.org/A001694 -- 2-powerful numbers\n#   https://oeis.org/A036966 -- 3-powerful numbers\n#   https://oeis.org/A036967 -- 4-powerful numbers\n#   https://oeis.org/A069492 -- 5-powerful numbers\n#   https://oeis.org/A069493 -- 6-powerful numbers\n\n# See also:\n#   https://oeis.org/A118896 -- Number of powerful numbers <= 10^n.\n\nuse 5.020;\nuse warnings;\n\nuse ntheory      qw(rootint divint gcd is_square_free mulint powint);\nuse experimental qw(signatures);\n\nsub powerful_count ($n, $k = 2) {\n\n    my $count = 0;\n\n    sub ($m, $r) {\n\n        if ($r <= $k) {\n            $count += rootint(divint($n, $m), $r);\n            return;\n        }\n\n        foreach my $v (1 .. rootint(divint($n, $m), $r)) {\n\n            gcd($m, $v) == 1   or next;\n            is_square_free($v) or next;\n\n            __SUB__->(mulint($m, powint($v, $r)), $r - 1);\n        }\n      }\n      ->(1, 2 * $k - 1);\n\n    return $count;\n}\n\nforeach my $k (2 .. 10) {\n    printf(\"Number of %2d-powerful <= 10^j: {%s}\\n\", $k, join(', ', map { powerful_count(powint(10, $_), $k) } 0 .. ($k + 15)));\n}\n\n__END__\nNumber of  2-powerful <= 10^j: {1, 4, 14, 54, 185, 619, 2027, 6553, 21044, 67231, 214122, 680330, 2158391, 6840384, 21663503, 68575557, 217004842, 686552743}\nNumber of  3-powerful <= 10^j: {1, 2, 7, 20, 51, 129, 307, 713, 1645, 3721, 8348, 18589, 41136, 90619, 198767, 434572, 947753, 2062437, 4480253}\nNumber of  4-powerful <= 10^j: {1, 1, 5, 11, 25, 57, 117, 235, 464, 906, 1741, 3312, 6236, 11654, 21661, 40049, 73699, 135059, 246653, 449088}\nNumber of  5-powerful <= 10^j: {1, 1, 3, 8, 16, 32, 63, 117, 211, 375, 659, 1153, 2000, 3402, 5770, 9713, 16266, 27106, 45003, 74410, 122594}\nNumber of  6-powerful <= 10^j: {1, 1, 2, 6, 12, 21, 38, 70, 121, 206, 335, 551, 900, 1451, 2326, 3706, 5853, 9167, 14316, 22261, 34471, 53222}\nNumber of  7-powerful <= 10^j: {1, 1, 1, 4, 10, 16, 26, 46, 77, 129, 204, 318, 495, 761, 1172, 1799, 2740, 4128, 6200, 9224, 13671, 20205, 29764}\nNumber of  8-powerful <= 10^j: {1, 1, 1, 3, 8, 13, 19, 32, 52, 85, 135, 211, 315, 467, 689, 1016, 1496, 2191, 3214, 4653, 6705, 9610, 13694, 19460}\nNumber of  9-powerful <= 10^j: {1, 1, 1, 2, 6, 11, 16, 24, 38, 59, 94, 145, 217, 317, 453, 644, 919, 1308, 1868, 2651, 3745, 5259, 7337, 10203, 14090}\nNumber of 10-powerful <= 10^j: {1, 1, 1, 1, 5, 9, 14, 21, 28, 43, 68, 104, 155, 227, 322, 447, 621, 858, 1192, 1651, 2279, 3152, 4334, 5928, 8075, 10943}\n"
  },
  {
    "path": "Math/count_of_k-powerful_numbers_in_range.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 28 February 2021\n# Edit: 11 April 2024\n# https://github.com/trizen\n\n# Fast recursive algorithm for counting the number of k-powerful numbers in a given range [A,B].\n# A positive integer n is considered k-powerful, if for every prime p that divides n, so does p^k.\n\n# Example:\n#   2-powerful = a^2 * b^3,             for a,b >= 1\n#   3-powerful = a^3 * b^4 * c^5,       for a,b,c >= 1\n#   4-powerful = a^4 * b^5 * c^6 * d^7, for a,b,c,d >= 1\n\n# OEIS:\n#   https://oeis.org/A001694 -- 2-powerful numbers\n#   https://oeis.org/A036966 -- 3-powerful numbers\n#   https://oeis.org/A036967 -- 4-powerful numbers\n#   https://oeis.org/A069492 -- 5-powerful numbers\n#   https://oeis.org/A069493 -- 6-powerful numbers\n\n# See also:\n#   https://oeis.org/A118896 -- Number of powerful numbers <= 10^n.\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\n\nsub powerful_count_in_range ($A, $B, $k = 2) {\n\n    return 0 if ($A > $B);\n\n    my $count = 0;\n\n    sub ($m, $r) {\n\n        my $from = 1;\n        my $upto = rootint(divint($B, $m), $r);\n\n        if ($r <= $k) {\n\n            if ($A > $m) {\n\n                # Optimization by Dana Jacobsen (from Math::Prime::Util::PP)\n                my $l = cdivint($A, $m);\n                if (($l >> $r) == 0) {\n                    $from = 2;\n                }\n                else {\n                    $from = rootint($l, $r);\n                    $from++ if (powint($from, $r) != $l);\n                }\n            }\n\n            $count += $upto - $from + 1;\n            return;\n        }\n\n        foreach my $v ($from .. $upto) {\n            gcd($m, $v) == 1   or next;\n            is_square_free($v) or next;\n            __SUB__->(mulint($m, powint($v, $r)), $r - 1);\n        }\n      }\n      ->(1, 2 * $k - 1);\n\n    return $count;\n}\n\nrequire Math::Sidef;\n\nforeach my $k (2 .. 10) {\n\n    my $lo = int rand powint(10, $k - 1);\n    my $hi = int rand powint(10, $k);\n\n    my $c1 = powerful_count_in_range($lo, $hi, $k);\n    my $c2 = Math::Sidef::powerful_count($k, $lo, $hi);\n\n    $c1 eq $c2 or die \"Error for [$lo, $hi] -- ($c1 != $c2)\\n\";\n\n    printf(\"Number of %2d-powerful in range 10^j .. 10^(j+1): {%s}\\n\",\n           $k, join(\", \", map { powerful_count_in_range(powint(10, $_), powint(10, $_ + 1), $k) } 0 .. $k + 7));\n}\n\n__END__\nNumber of  2-powerful in range 10^j .. 10^(j+1): {4, 10, 41, 132, 435, 1409, 4527, 14492, 46188, 146892}\nNumber of  3-powerful in range 10^j .. 10^(j+1): {2, 5, 13, 32, 79, 179, 407, 933, 2077, 4628, 10242}\nNumber of  4-powerful in range 10^j .. 10^(j+1): {1, 4, 6, 14, 33, 61, 119, 230, 443, 836, 1572, 2925}\nNumber of  5-powerful in range 10^j .. 10^(j+1): {1, 2, 5, 8, 16, 32, 55, 95, 165, 285, 495, 848, 1403}\nNumber of  6-powerful in range 10^j .. 10^(j+1): {1, 1, 4, 6, 9, 17, 33, 52, 86, 130, 217, 350, 552, 876}\nNumber of  7-powerful in range 10^j .. 10^(j+1): {1, 0, 3, 6, 6, 10, 20, 32, 53, 76, 115, 178, 267, 412, 628}\nNumber of  8-powerful in range 10^j .. 10^(j+1): {1, 0, 2, 5, 5, 6, 13, 20, 34, 51, 77, 105, 153, 223, 328, 481}\nNumber of  9-powerful in range 10^j .. 10^(j+1): {1, 0, 1, 4, 5, 5, 8, 14, 21, 36, 52, 73, 101, 137, 192, 276, 390}\nNumber of 10-powerful in range 10^j .. 10^(j+1): {1, 0, 0, 4, 4, 5, 7, 7, 15, 25, 37, 52, 73, 96, 126, 175, 238, 335}\n"
  },
  {
    "path": "Math/count_of_perfect_powers.pl",
    "content": "#!/usr/bin/perl\n\n# Efficient formula for counting the numbers of perfect powers <= n.\n\n# Formula:\n#   a(n) = n - Sum_{1..floor(log_2(n))} mu(k) * (floor(n^(1/k)) - 1)\n#        = 1 - Sum_{2..floor(log_2(n))} mu(k) * (floor(n^(1/k)) - 1)\n\n# See also:\n#   https://oeis.org/A069623\n\nuse 5.036;\nuse ntheory qw(logint rootint moebius vecsum);\n\nsub perfect_power_count ($n) {\n    1 - vecsum(map { moebius($_) * (rootint($n, $_) - 1) } 2 .. logint($n, 2));\n}\n\nforeach my $n (0 .. 15) {\n    printf(\"a(10^%d) = %s\\n\", $n, perfect_power_count(10**$n));\n}\n\n__END__\na(10^0) = 1\na(10^1) = 4\na(10^2) = 13\na(10^3) = 41\na(10^4) = 125\na(10^5) = 367\na(10^6) = 1111\na(10^7) = 3395\na(10^8) = 10491\na(10^9) = 32670\na(10^10) = 102231\na(10^11) = 320990\na(10^12) = 1010196\na(10^13) = 3184138\na(10^14) = 10046921\na(10^15) = 31723592\n"
  },
  {
    "path": "Math/count_of_prime_power.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 02 December 2018\n# https://github.com/trizen\n\n# A nice algorithm in terms of the prime-counting function for computing the number of prime powers <= n.\n#   a(n) = Sum_{k=1..floor(log_2(n))} π(floor(n^(1/k)))\n\n# Example: a(10^n) for n=1..15:\n#   a(10^1)  = 7\n#   a(10^2)  = 35\n#   a(10^3)  = 193\n#   a(10^4)  = 1280\n#   a(10^5)  = 9700\n#   a(10^6)  = 78734\n#   a(10^7)  = 665134\n#   a(10^8)  = 5762859\n#   a(10^9)  = 50851223\n#   a(10^10) = 455062595\n#   a(10^11) = 4118082969\n#   a(10^12) = 37607992088\n#   a(10^13) = 346065767406\n#   a(10^14) = 3204942420923\n#   a(10^15) = 29844572385358\n\n# See also:\n#   https://oeis.org/A025528\n#   https://oeis.org/A267712\n#   https://en.wikipedia.org/wiki/Prime-counting_function\n#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(vecsum logint rootint prime_count);\n\nsub prime_power_count($n) {\n    vecsum(map { prime_count(rootint($n, $_)) } 1 .. logint($n, 2));\n}\n\nforeach my $n (1 .. 14) {   # takes ~2.1s\n    say \"a(10^$n) = \", prime_power_count(10**$n);\n}\n"
  },
  {
    "path": "Math/count_of_prime_signature_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 22 April 2026\n# https://github.com/trizen\n\n# Count the number of k-omega numbers <= n that have a given prime signature.\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\n\nprime_precalc(1e7);\n\nsub count_prime_signature_numbers($n, $prime_signature) {\n\n    my $k = scalar(@$prime_signature);\n\n    if ($k == 0) {\n        return 1 if (1 <= $n);\n        return 0;\n    }\n\n    $n >= 1 || return 0;\n\n    my $count = 0;\n\n    my $generate = sub ($m, $lo, $k, $P, $sum_e, $j = 0) {\n\n        my $e = $P->[$k - 1];\n        my $hi = rootint(divint($n, $m), $sum_e);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        if ($k == 1) {\n            $count += prime_count($hi) - $j;\n            return;\n        }\n\n        if ($k == 2) {\n            my $e2 = $P->[0];\n            foreach my $p (@{primes($lo, $hi)}) {\n                my $t = mulint($m, powint($p, $e));\n                my $u = rootint(divint($n, $t), $e2);\n                $count += prime_count($u) - ++$j;\n            }\n            return;\n        }\n\n        for (my $p = $lo; $p <= $hi; ) {\n            my $t = mulint($m, powint($p, $e));\n            my $r = next_prime($p);\n            __SUB__->($t, $r, $k - 1, $P, $sum_e - $e, ++$j);\n            $p = $r;\n        }\n    };\n\n    my %seen;\n    my $sum_e = vecsum(@$prime_signature) || return 0;\n\n    if ($sum_e > logint($n, 2)) {\n        return 0;\n    }\n\n    forperm {\n        my @perm = @{$prime_signature}[@_];\n        if (!$seen{join(' ', @perm)}++) {\n            $generate->(1, 2, scalar(@perm), \\@perm, $sum_e);\n        }\n    } $k;\n\n    return $count;\n}\n\nsub count_prime_signature_numbers_in_range($A, $B, $signature) {\n    my $term_1 = count_prime_signature_numbers($A - 1, $signature);\n    my $term_2 = count_prime_signature_numbers($B,     $signature);\n    $term_2 - $term_1;\n}\n\n#\n## Example\n#\nsub A395379($n) {\n    my $A = powint((nth_prime($n - 1) || 1), 7);\n    my $B = powint(nth_prime($n),            7) - 1;\n\n    my $term_1 = count_prime_signature_numbers_in_range($A, $B, [7]);\n    my $term_2 = count_prime_signature_numbers_in_range($A, $B, [3, 1]);\n    my $term_3 = count_prime_signature_numbers_in_range($A, $B, [1, 1, 1]);\n\n    $term_1 + $term_2 + $term_3;\n}\n\njoin(' ', map { A395379($_) } 1 .. 9) eq join(' ', 15, 408, 16838, 167649, 4140037, 9474308, 74874018, 102945521, 527810589)\n  or die \"error\";\n\nmy $prime_signature = [3, 2, 2];\nmy $n               = 10000;\n\ncount_prime_signature_numbers($n, $prime_signature) == 7                or die \"error\";\ncount_prime_signature_numbers_in_range(2e3, 1e4, $prime_signature) == 6 or die \"error\";\n"
  },
  {
    "path": "Math/count_of_rough_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 20 July 2020\n# https://github.com/trizen\n\n# Count the number of B-rough numbers <= n.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Rough_number\n\nuse 5.020;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub my_rough_count ($n, $p) {\n\n    my %cache;\n\n    sub ($n, $p) {\n\n        if ($p > sqrtint($n)) {\n            return 1;\n        }\n\n        if ($p == 2) {\n            return ($n >> 1);\n        }\n\n        if ($p == 3) {\n            my $t = divint($n, 3);\n            return ($t - ($t >> 1));\n        }\n\n        my $key = \"$n,$p\";\n\n        return $cache{$key}\n            if exists $cache{$key};\n\n        my $u = 0;\n        my $t = divint($n, $p);\n\n        for (my $q = 2 ; $q < $p ; $q = next_prime($q)) {\n\n            my $v = __SUB__->($t - ($t % $q), $q);\n\n            if ($v == 1) {\n                $u += prime_count($q, $p - 1);\n                last;\n            }\n            else {\n                $u += $v;\n            }\n        }\n\n        $cache{$key} = $t - $u;\n    }->($n * $p, $p);\n}\n\nforeach my $p (@{primes(30)}) {\n    say \"Φ(10^n, $p) for n <= 10: [\", join(', ', map { my_rough_count(powint(10, $_), $p) } 0 .. 10), \"]\";\n}\n\n__END__\nΦ(10^n,  2) for n <= 10: [1, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000, 10000000000]\nΦ(10^n,  3) for n <= 10: [1, 5, 50, 500, 5000, 50000, 500000, 5000000, 50000000, 500000000, 5000000000]\nΦ(10^n,  5) for n <= 10: [1, 3, 33, 333, 3333, 33333, 333333, 3333333, 33333333, 333333333, 3333333333]\nΦ(10^n,  7) for n <= 10: [1, 2, 26, 266, 2666, 26666, 266666, 2666666, 26666666, 266666666, 2666666666]\nΦ(10^n, 11) for n <= 10: [1, 1, 22, 228, 2285, 22857, 228571, 2285713, 22857142, 228571428, 2285714285]\nΦ(10^n, 13) for n <= 10: [1, 1, 21, 207, 2077, 20779, 207792, 2077921, 20779221, 207792207, 2077922077]\nΦ(10^n, 17) for n <= 10: [1, 1, 20, 190, 1917, 19181, 191808, 1918081, 19180820, 191808190, 1918081917]\nΦ(10^n, 19) for n <= 10: [1, 1, 19, 179, 1806, 18053, 180524, 1805251, 18052535, 180525355, 1805253568]\nΦ(10^n, 23) for n <= 10: [1, 1, 18, 170, 1711, 17103, 171021, 1710234, 17102401, 171024023, 1710240224]\nΦ(10^n, 29) for n <= 10: [1, 1, 17, 163, 1634, 16361, 163586, 1635877, 16358819, 163588196, 1635881952]\n"
  },
  {
    "path": "Math/count_of_rough_numbers_recursive.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 05 September 2025\n# Edit: 13 March 2026\n# https://github.com/trizen\n\n# Count the number of B-rough numbers <= n.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Rough_number\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\n\nsub my_rough_count($n, $k) {\n\n    my @P = @{primes($k - 1)};\n\n    return $n if (@P == 0);\n\n    my %cache;\n\n    sub ($n, $a) {\n\n        # Meissel-Lehmer truncation (The Sublinear Secret)\n        if ($P[$a - 1] > sqrt($n)) {\n            return prime_count($n) - $a + 1;\n        }\n\n        return $cache{$a}{$n}\n          if exists $cache{$a}{$n};\n\n        # Initial count: odd numbers ≤ n\n        my $count = $n - ($n >> 1);\n\n        # Inclusion-Exclusion principle\n        for my $j (1 .. $a - 1) {\n            last if ($P[$j] > $n);\n            $count -= __SUB__->(divint($n, $P[$j]), $j);\n        }\n\n        $cache{$a}{$n} = $count;\n    }->($n, scalar @P);\n}\n\nforeach my $p (@{primes(30)}) {\n    say \"Φ(10^n, $p) for n <= 10: [\", join(', ', map { my_rough_count(powint(10, $_), $p) } 0 .. 10), \"]\";\n}\n\n__END__\nΦ(10^n,  2) for n <= 10: [1, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000, 10000000000]\nΦ(10^n,  3) for n <= 10: [1, 5, 50, 500, 5000, 50000, 500000, 5000000, 50000000, 500000000, 5000000000]\nΦ(10^n,  5) for n <= 10: [1, 3, 33, 333, 3333, 33333, 333333, 3333333, 33333333, 333333333, 3333333333]\nΦ(10^n,  7) for n <= 10: [1, 2, 26, 266, 2666, 26666, 266666, 2666666, 26666666, 266666666, 2666666666]\nΦ(10^n, 11) for n <= 10: [1, 1, 22, 228, 2285, 22857, 228571, 2285713, 22857142, 228571428, 2285714285]\nΦ(10^n, 13) for n <= 10: [1, 1, 21, 207, 2077, 20779, 207792, 2077921, 20779221, 207792207, 2077922077]\nΦ(10^n, 17) for n <= 10: [1, 1, 20, 190, 1917, 19181, 191808, 1918081, 19180820, 191808190, 1918081917]\nΦ(10^n, 19) for n <= 10: [1, 1, 19, 179, 1806, 18053, 180524, 1805251, 18052535, 180525355, 1805253568]\nΦ(10^n, 23) for n <= 10: [1, 1, 18, 170, 1711, 17103, 171021, 1710234, 17102401, 171024023, 1710240224]\nΦ(10^n, 29) for n <= 10: [1, 1, 17, 163, 1634, 16361, 163586, 1635877, 16358819, 163588196, 1635881952]\n"
  },
  {
    "path": "Math/count_of_smooth_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 19 May 2020\n# https://github.com/trizen\n\n# Count the number of B-smooth numbers <= n.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Smooth_number\n\nuse 5.036;\nuse ntheory qw(:all);\n\nsub my_smooth_count ($n, $p) {\n\n    if ($p == 2) {\n        return 1 + logint($n, 2);\n    }\n\n    my $q = prev_prime($p);\n\n    my $count = 0;\n    foreach my $k (0 .. logint($n, $p)) {\n        $count += __SUB__->(divint($n, powint($p, $k)), $q);\n    }\n\n    return $count;\n}\n\nforeach my $p (@{primes(50)}) {\n    say \"Ψ(10^n, $p) for n <= 10: [\", join(', ', map { my_smooth_count(powint(10, $_), $p) } 0 .. 10), \"]\";\n}\n\n__END__\nΨ(10^n, 2) for n <= 10: [1, 4, 7, 10, 14, 17, 20, 24, 27, 30, 34]\nΨ(10^n, 3) for n <= 10: [1, 7, 20, 40, 67, 101, 142, 190, 244, 306, 376]\nΨ(10^n, 5) for n <= 10: [1, 9, 34, 86, 175, 313, 507, 768, 1105, 1530, 2053]\nΨ(10^n, 7) for n <= 10: [1, 10, 46, 141, 338, 694, 1273, 2155, 3427, 5194, 7575]\nΨ(10^n, 11) for n <= 10: [1, 10, 55, 192, 522, 1197, 2432, 4520, 7838, 12867, 20193]\nΨ(10^n, 13) for n <= 10: [1, 10, 62, 242, 733, 1848, 4106, 8289, 15519, 27365, 45914]\nΨ(10^n, 17) for n <= 10: [1, 10, 67, 287, 945, 2579, 6179, 13389, 26809, 50351, 89679]\nΨ(10^n, 19) for n <= 10: [1, 10, 72, 331, 1169, 3419, 8751, 20198, 42950, 85411, 160626]\nΨ(10^n, 23) for n <= 10: [1, 10, 76, 369, 1385, 4298, 11654, 28434, 63768, 133440, 263529]\nΨ(10^n, 29) for n <= 10: [1, 10, 79, 402, 1581, 5158, 14697, 37627, 88415, 193571, 399341]\nΨ(10^n, 31) for n <= 10: [1, 10, 82, 434, 1778, 6070, 18083, 48366, 118599, 270648, 581272]\nΨ(10^n, 37) for n <= 10: [1, 10, 84, 461, 1958, 6952, 21535, 59867, 152482, 361173, 804369]\nΨ(10^n, 41) for n <= 10: [1, 10, 86, 485, 2129, 7833, 25133, 72345, 190767, 467495, 1076462]\nΨ(10^n, 43) for n <= 10: [1, 10, 88, 508, 2300, 8740, 28955, 86086, 234423, 592949, 1408465]\nΨ(10^n, 47) for n <= 10: [1, 10, 90, 529, 2463, 9639, 32876, 100688, 282397, 735425, 1797897]\n"
  },
  {
    "path": "Math/count_of_smooth_numbers_memoized.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 06 April 2026\n# https://github.com/trizen\n\n# Count the number of B-smooth numbers <= n. (memoized version)\n\n# See also:\n#   https://en.wikipedia.org/wiki/Smooth_number\n\nuse 5.036;\nuse ntheory qw(:all);\n\nsub my_smooth_count ($n, $p) {\n\n    my @cache;\n    my @P = @{primes($p)};\n\n    sub ($x, $i) {\n\n        $x || return 0;\n\n        # Count powers of 2 in [1..$x] = number of bits in $x.\n        $i || return 1 + logint($x, 2);\n\n        # All of 1..$x are P[$i]-smooth when $x < P[$i]\n        return $x if $x < $P[$i];\n\n        $cache[$i]{$x} //= __SUB__->($x, $i - 1) + __SUB__->(divint($x, $P[$i]), $i);\n    }->($n, $#P);\n}\n\nforeach my $p (@{primes(50)}) {\n    say \"Ψ(10^n, $p) for n <= 10: [\", join(', ', map { my_smooth_count(powint(10, $_), $p) } 0 .. 10), \"]\";\n}\n\n__END__\nΨ(10^n, 2) for n <= 10: [1, 4, 7, 10, 14, 17, 20, 24, 27, 30, 34]\nΨ(10^n, 3) for n <= 10: [1, 7, 20, 40, 67, 101, 142, 190, 244, 306, 376]\nΨ(10^n, 5) for n <= 10: [1, 9, 34, 86, 175, 313, 507, 768, 1105, 1530, 2053]\nΨ(10^n, 7) for n <= 10: [1, 10, 46, 141, 338, 694, 1273, 2155, 3427, 5194, 7575]\nΨ(10^n, 11) for n <= 10: [1, 10, 55, 192, 522, 1197, 2432, 4520, 7838, 12867, 20193]\nΨ(10^n, 13) for n <= 10: [1, 10, 62, 242, 733, 1848, 4106, 8289, 15519, 27365, 45914]\nΨ(10^n, 17) for n <= 10: [1, 10, 67, 287, 945, 2579, 6179, 13389, 26809, 50351, 89679]\nΨ(10^n, 19) for n <= 10: [1, 10, 72, 331, 1169, 3419, 8751, 20198, 42950, 85411, 160626]\nΨ(10^n, 23) for n <= 10: [1, 10, 76, 369, 1385, 4298, 11654, 28434, 63768, 133440, 263529]\nΨ(10^n, 29) for n <= 10: [1, 10, 79, 402, 1581, 5158, 14697, 37627, 88415, 193571, 399341]\nΨ(10^n, 31) for n <= 10: [1, 10, 82, 434, 1778, 6070, 18083, 48366, 118599, 270648, 581272]\nΨ(10^n, 37) for n <= 10: [1, 10, 84, 461, 1958, 6952, 21535, 59867, 152482, 361173, 804369]\nΨ(10^n, 41) for n <= 10: [1, 10, 86, 485, 2129, 7833, 25133, 72345, 190767, 467495, 1076462]\nΨ(10^n, 43) for n <= 10: [1, 10, 88, 508, 2300, 8740, 28955, 86086, 234423, 592949, 1408465]\nΨ(10^n, 47) for n <= 10: [1, 10, 90, 529, 2463, 9639, 32876, 100688, 282397, 735425, 1797897]\n"
  },
  {
    "path": "Math/count_of_smooth_numbers_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 18 July 2020\n# https://github.com/trizen\n\n# Count the number of B-smooth numbers <= n.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Smooth_number\n\nuse 5.036;\nuse ntheory qw(:all);\n\nuse Math::GMPz;\n\nsub my_smooth_count ($n, $k) {\n\n    if (ref($n) ne 'Math::GMPz') {\n        $n = Math::GMPz->new(\"$n\");\n    }\n\n    if ($k < 2 or Math::GMPz::Rmpz_sgn($n) <= 0) {\n        return 0;\n    }\n\n    if (Math::GMPz::Rmpz_cmp_ui($n, $k) <= 0) {\n        return $n;\n    }\n\n    my $count = sub {\n        my ($n, $p) = @_;\n\n        if ($p == 2) {\n            return Math::GMPz::Rmpz_sizeinbase($n, 2);\n        }\n\n        my $t = Math::GMPz::Rmpz_init();\n        my $q = prev_prime($p);\n\n        my $sum = 0;\n\n        for (my $k = 0; ; ++$k) {\n\n            Math::GMPz::Rmpz_ui_pow_ui($t, $p, $k);\n            Math::GMPz::Rmpz_tdiv_q($t, $n, $t);\n\n            if (Math::GMPz::Rmpz_cmp_ui($t, $q) <= 0) {\n                $sum += Math::GMPz::Rmpz_get_ui($t);\n                last;\n            }\n            else {\n                $sum += __SUB__->($t, $q);\n            }\n        }\n\n        $sum;\n    }->($n, prev_prime($k + 1));\n\n    return $count;\n}\n\nforeach my $p (@{primes(50)}) {\n    say \"Ψ(10^n, $p) for n <= 10: [\", join(', ', map { my_smooth_count(powint(10, $_), $p) } 0 .. 10), \"]\";\n}\n\n__END__\nΨ(10^n,  2) for n <= 10: [1, 4, 7, 10, 14, 17, 20, 24, 27, 30, 34]\nΨ(10^n,  3) for n <= 10: [1, 7, 20, 40, 67, 101, 142, 190, 244, 306, 376]\nΨ(10^n,  5) for n <= 10: [1, 9, 34, 86, 175, 313, 507, 768, 1105, 1530, 2053]\nΨ(10^n,  7) for n <= 10: [1, 10, 46, 141, 338, 694, 1273, 2155, 3427, 5194, 7575]\nΨ(10^n, 11) for n <= 10: [1, 10, 55, 192, 522, 1197, 2432, 4520, 7838, 12867, 20193]\nΨ(10^n, 13) for n <= 10: [1, 10, 62, 242, 733, 1848, 4106, 8289, 15519, 27365, 45914]\nΨ(10^n, 17) for n <= 10: [1, 10, 67, 287, 945, 2579, 6179, 13389, 26809, 50351, 89679]\nΨ(10^n, 19) for n <= 10: [1, 10, 72, 331, 1169, 3419, 8751, 20198, 42950, 85411, 160626]\nΨ(10^n, 23) for n <= 10: [1, 10, 76, 369, 1385, 4298, 11654, 28434, 63768, 133440, 263529]\nΨ(10^n, 29) for n <= 10: [1, 10, 79, 402, 1581, 5158, 14697, 37627, 88415, 193571, 399341]\nΨ(10^n, 31) for n <= 10: [1, 10, 82, 434, 1778, 6070, 18083, 48366, 118599, 270648, 581272]\nΨ(10^n, 37) for n <= 10: [1, 10, 84, 461, 1958, 6952, 21535, 59867, 152482, 361173, 804369]\nΨ(10^n, 41) for n <= 10: [1, 10, 86, 485, 2129, 7833, 25133, 72345, 190767, 467495, 1076462]\nΨ(10^n, 43) for n <= 10: [1, 10, 88, 508, 2300, 8740, 28955, 86086, 234423, 592949, 1408465]\nΨ(10^n, 47) for n <= 10: [1, 10, 90, 529, 2463, 9639, 32876, 100688, 282397, 735425, 1797897]\n"
  },
  {
    "path": "Math/count_of_smooth_numbers_mpz_2.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 19 July 2020\n# https://github.com/trizen\n\n# Count the number of B-smooth numbers <= n.\n\n# Inspired by Dana Jacobsen's \"smooth_count(n,k)\" algorithm from Math::Prime::Util::PP.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Smooth_number\n\nuse 5.036;\nuse ntheory qw(:all);\n\nuse Math::GMPz;\n\nsub my_smooth_count ($n, $k) {\n\n    if (ref($n) ne 'Math::GMPz') {\n        $n = Math::GMPz->new(\"$n\");\n    }\n\n    if ($k < 2 or Math::GMPz::Rmpz_sgn($n) <= 0) {\n        return 0;\n    }\n\n    if (Math::GMPz::Rmpz_cmp_ui($n, $k) <= 0) {\n        return $n;\n    }\n\n    my $count = sub ($n, $k) {\n\n        my $sum = Math::GMPz::Rmpz_sizeinbase($n, 2);\n\n        if ($k == 2) {\n            return $sum;\n        }\n\n        my $t = Math::GMPz::Rmpz_init();\n\n        for (my $p = 3 ; $p <= $k ; $p = next_prime($p)) {\n\n            Math::GMPz::Rmpz_tdiv_q_ui($t, $n, $p);\n\n            if (Math::GMPz::Rmpz_cmp_ui($t, $p) <= 0) {\n                $sum += Math::GMPz::Rmpz_get_ui($t);\n            }\n            else {\n                $sum += __SUB__->($t, $p);\n            }\n        }\n\n        $sum;\n    }->($n, prev_prime($k + 1));\n\n    return $count;\n}\n\nforeach my $p (@{primes(50)}) {\n    say \"Ψ(10^n, $p) for n <= 10: [\", join(', ', map { my_smooth_count(powint(10, $_), $p) } 0 .. 10), \"]\";\n}\n\n__END__\nΨ(10^n,  2) for n <= 10: [1, 4, 7, 10, 14, 17, 20, 24, 27, 30, 34]\nΨ(10^n,  3) for n <= 10: [1, 7, 20, 40, 67, 101, 142, 190, 244, 306, 376]\nΨ(10^n,  5) for n <= 10: [1, 9, 34, 86, 175, 313, 507, 768, 1105, 1530, 2053]\nΨ(10^n,  7) for n <= 10: [1, 10, 46, 141, 338, 694, 1273, 2155, 3427, 5194, 7575]\nΨ(10^n, 11) for n <= 10: [1, 10, 55, 192, 522, 1197, 2432, 4520, 7838, 12867, 20193]\nΨ(10^n, 13) for n <= 10: [1, 10, 62, 242, 733, 1848, 4106, 8289, 15519, 27365, 45914]\nΨ(10^n, 17) for n <= 10: [1, 10, 67, 287, 945, 2579, 6179, 13389, 26809, 50351, 89679]\nΨ(10^n, 19) for n <= 10: [1, 10, 72, 331, 1169, 3419, 8751, 20198, 42950, 85411, 160626]\nΨ(10^n, 23) for n <= 10: [1, 10, 76, 369, 1385, 4298, 11654, 28434, 63768, 133440, 263529]\nΨ(10^n, 29) for n <= 10: [1, 10, 79, 402, 1581, 5158, 14697, 37627, 88415, 193571, 399341]\nΨ(10^n, 31) for n <= 10: [1, 10, 82, 434, 1778, 6070, 18083, 48366, 118599, 270648, 581272]\nΨ(10^n, 37) for n <= 10: [1, 10, 84, 461, 1958, 6952, 21535, 59867, 152482, 361173, 804369]\nΨ(10^n, 41) for n <= 10: [1, 10, 86, 485, 2129, 7833, 25133, 72345, 190767, 467495, 1076462]\nΨ(10^n, 43) for n <= 10: [1, 10, 88, 508, 2300, 8740, 28955, 86086, 234423, 592949, 1408465]\nΨ(10^n, 47) for n <= 10: [1, 10, 90, 529, 2463, 9639, 32876, 100688, 282397, 735425, 1797897]\n"
  },
  {
    "path": "Math/count_of_smooth_numbers_with_k_factors.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 05 March 2020\n# https://github.com/trizen\n\n# Count the number of B-smooth numbers below a given limit, where each number has at least k distinct prime factors.\n\n# Problem inspired by:\n#   https://projecteuler.net/problem=268\n\n# See also:\n#   https://en.wikipedia.org/wiki/Smooth_number\n\nuse 5.020;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub smooth_numbers ($initial, $limit, $primes) {\n\n    my @h = ($initial);\n\n    foreach my $p (@$primes) {\n        foreach my $n (@h) {\n            if ($n * $p <= $limit) {\n                push @h, $n * $p;\n            }\n        }\n    }\n\n    return \\@h;\n}\n\nmy $PRIME_MAX = 100;    # the prime factors must all be <= this value\nmy $LEAST_K   = 4;      # each number must have at least this many distinct prime factors\n\nsub count_smooth_numbers ($limit) {\n\n    my $count  = 0;\n    my @primes = @{primes($PRIME_MAX)};\n\n    forcomb {\n\n        my $c = [@primes[@_]];\n        my $v = vecprod(@$c);\n\n        if ($v <= $limit) {\n\n            my $h = smooth_numbers($v, $limit, $c);\n\n            foreach my $n (@$h) {\n                my $new_h = smooth_numbers(1, divint($limit, $n), [grep { $_ < $c->[0] } @primes]);\n                $count += scalar @$new_h;\n            }\n        }\n\n    } scalar(@primes), $LEAST_K;\n\n    return $count;\n}\n\nsay \"\\n# Count of $PRIME_MAX-smooth numbers with at least $LEAST_K distinct prime factors:\\n\";\n\nforeach my $n (1 .. 16) {\n    my $count = count_smooth_numbers(powint(10, $n));\n    say \"C(10^$n) = $count\";\n}\n\n__END__\n\n# Count of 100-smooth numbers with at least 4 distinct prime factors:\n\nC(10^1)  = 0\nC(10^2)  = 0\nC(10^3)  = 23\nC(10^4)  = 811\nC(10^5)  = 8963\nC(10^6)  = 53808\nC(10^7)  = 235362\nC(10^8)  = 866945\nC(10^9)  = 2855050\nC(10^10) = 8668733\nC(10^11) = 24692618\nC(10^12) = 66682074\nC(10^13) = 171957884\nC(10^14) = 425693882\nC(10^15) = 1015820003\nC(10^16) = 2344465914\n"
  },
  {
    "path": "Math/count_of_squarefree_k-almost_primes.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 15 March 2021\n# https://github.com/trizen\n\n# Count the number of squarefree k-almost primes <= n.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n\n=for comment\n\n# PARI/GP program:\n\na(n,k) = my(N=10^n); (f(m, p, k, j=1)=my(s=sqrtnint(N\\m, k), count=0); if(k==2, forprime(q=p, s, count += primepi(N\\(m*q)) - j; j+=1); return(count)); forprime(q=p, s, count += f(m*q, q+1, k-1, j+1); j+=1); count); f(1, 2, k);\n\n=cut\n\nuse 5.020;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub squarefree_almost_prime_count ($n, $k) {\n\n    if ($k == 0) {\n        return (($n <= 0) ? 0 : 1);\n    }\n\n    if ($k == 1) {\n        return prime_count($n);\n    }\n\n    my $count = 0;\n\n    sub ($m, $p, $k, $j = 1) {\n\n        my $s = rootint(divint($n, $m), $k);\n\n        if ($k == 2) {\n\n            forprimes {\n                $count += prime_count(divint($n, mulint($m, $_))) - $j++;\n            } $p, $s;\n\n            return;\n        }\n\n        for (; $p <= $s ; ++$j) {\n            my $r = next_prime($p);\n            __SUB__->(mulint($m, $p), $r, $k - 1, $j + 1);\n            $p = $r;\n        }\n    }->(1, 2, $k);\n\n    return $count;\n}\n\n# Run some tests\n\nforeach my $k (1 .. 7) {\n\n    my $upto = pn_primorial($k) + int(rand(1e5));\n\n    my $x = squarefree_almost_prime_count($upto, $k);\n    my $y = scalar grep { is_square_free($_) } @{almost_primes($k, 1, $upto)};\n\n    say \"Testing: $k with n = $upto -> $x\";\n\n    $x == $y\n      or die \"Error: $x != $y\";\n}\n\nsay '';\n\nforeach my $k (1 .. 8) {\n    say(\"Count of squarefree $k-almost primes for 10^n: \",\n        join(', ', map { squarefree_almost_prime_count(10**$_, $k) } 0 .. 9));\n}\n\n__END__\nCount of squarefree 1-almost primes for 10^n: 0, 4, 25, 168, 1229, 9592, 78498, 664579, 5761455, 50847534\nCount of squarefree 2-almost primes for 10^n: 0, 2, 30, 288, 2600, 23313, 209867, 1903878, 17426029, 160785135\nCount of squarefree 3-almost primes for 10^n: 0, 0, 5, 135, 1800, 19919, 206964, 2086746, 20710806, 203834084\nCount of squarefree 4-almost primes for 10^n: 0, 0, 0, 16, 429, 7039, 92966, 1103888, 12364826, 133702610\nCount of squarefree 5-almost primes for 10^n: 0, 0, 0, 0, 24, 910, 18387, 286758, 3884936, 48396263\nCount of squarefree 6-almost primes for 10^n: 0, 0, 0, 0, 0, 20, 1235, 32396, 605939, 9446284\nCount of squarefree 7-almost primes for 10^n: 0, 0, 0, 0, 0, 0, 8, 1044, 38186, 885674\nCount of squarefree 8-almost primes for 10^n: 0, 0, 0, 0, 0, 0, 0, 1, 516, 29421\n"
  },
  {
    "path": "Math/count_of_squarefree_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 09 February 2017\n# https://github.com/trizen\n\n# Counts the number of squarefree numbers in the range [1, n].\n\n# See also:\n#   https://oeis.org/A053462\n#   https://projecteuler.net/problem=193\n#   https://en.wikipedia.org/wiki/Square-free_integer\n#   https://en.wikipedia.org/wiki/M%C3%B6bius_function\n\nuse 5.010;\nuse strict;\nuse integer;\n\nuse ntheory qw(moebius sqrtint);\n\nsub squarefree_count {\n    my ($n) = @_;\n\n    my $k     = 1;\n    my $count = 0;\n\n    foreach my $m (moebius(1, sqrtint($n))) {\n        $count += $m * ($n / ($k++)**2);\n    }\n\n    return $count;\n}\n\nsay squarefree_count(10**9);    #=> 607927124\n"
  },
  {
    "path": "Math/count_subtriangles.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 20 September 2015\n# Website: https://github.com/trizen\n\n# A general formula for counting the number of possible triangles inside a triangle.\n\nuse strict;\nuse warnings;\n\n## The formula is:\n#\n#    Sum((2n+1)(k-n-1), {n=0, k-1})\n#\n# where \"k\" is the number of rows of the triangle.\n\n## Closed forms:\n#\n#   (k^3)/3 - (k^2)/2 + (k/6)\n#   (1/6)(k-1)k(2k-1)\n#\n\n# For example, the following triangle:\n#    1\n#   234\n#  56789\n\n# Has 3 rows and 5 different triangles inside:\n#    1\n#   234\n#  56789\n#\n#    1\n#   234\n#\n#    2\n#   567\n#\n#    3\n#   678\n#\n#    4\n#   789\n\nsub count_subtriangles {\n    my ($k) = @_;\n\n    my $sum = 0;\n    foreach my $n (0 .. $k - 1) {\n        $sum += (2 * $n + 1) * ($k - $n - 1);\n    }\n    $sum;\n}\n\nforeach my $k (1 .. 20) {\n    my $closed = ($k - 1) * $k * (2 * $k - 1) / 6;\n    printf(\"%2d: %10s %10s\\n\", $k, count_subtriangles($k), $closed);\n}\n\n__END__\n 1: 0\n 2: 1\n 3: 5\n 4: 14\n 5: 30\n 6: 55\n 7: 91\n 8: 140\n 9: 204\n10: 285\n11: 385\n12: 506\n13: 650\n14: 819\n15: 1015\n16: 1240\n17: 1496\n18: 1785\n19: 2109\n20: 2470\n"
  },
  {
    "path": "Math/cube-full_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Fast algorithm for generating all the cube-full numbers <= n.\n# A positive integer n is considered cube-full, if for every prime p that divides n, so does p^3.\n\n# See also:\n#   THE DISTRIBUTION OF CUBE-FULL NUMBERS, by P. SHIU (1990).\n\n# OEIS:\n#   https://oeis.org/A036966 -- 3-full (or cube-full, or cubefull) numbers: if a prime p divides n then so does p^3.\n\nuse 5.020;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub cubefull_numbers ($n) {    # cubefull numbers <= n\n\n    my @cubeful;\n\n    for my $a (1 .. rootint($n, 5)) {\n        is_square_free($a) || next;\n        for my $b (1 .. rootint(divint($n, powint($a, 5)), 4)) {\n            gcd($a, $b) == 1 or next;\n            is_square_free($b) || next;\n            my $v = mulint(powint($a, 5), powint($b, 4));\n            foreach my $c (1 .. rootint(divint($n, $v), 3)) {\n                my $z = vecprod($v, $c, $c, $c);\n                push @cubeful, $z;\n            }\n        }\n    }\n\n    sort { $a <=> $b } @cubeful;\n}\n\nsay join(', ', cubefull_numbers(1e4));\n\n__END__\n1, 8, 16, 27, 32, 64, 81, 125, 128, 216, 243, 256, 343, 432, 512, 625, 648, 729, 864, 1000, 1024, 1296, 1331, 1728, 1944, 2000, 2048, 2187, 2197, 2401, 2592, 2744, 3125, 3375, 3456, 3888, 4000, 4096, 4913, 5000, 5184, 5488, 5832, 6561, 6859, 6912, 7776, 8000, 8192, 9261, 10000\n"
  },
  {
    "path": "Math/cuboid.pl",
    "content": "       sub say{print@_,$/}sub cube\n      {my($x,$y,$z)=map{int}@_;my(\n     $c,$h,$v,$d,$s)=((qw{+ - | /}\n    ),$ARGV[3]||' ');my($p,$o)=(0,\n   0);say ' 'x($z+1),$c,$h x$x,$c;\n  for(1..$z){say ' 'x($z-$_+1),$d,\n $s x$x,$d,$s x($_-1-$p),$_>$y?!$p\n ?do{$p=1;$o=$z-$y;$c}:$p++?$d:$c:\n $v;}say$c,$h x$x,$c,$z<$y?do{$s x\n $z,$v}:$p?do{$s x($z-$o),$d}:do{$\n s x$z,$c};for(1..$y){say$v,$s x$x\n ,$v,$z-1>=$y?$_>=$z?($s x$x,$c):(\n $s x($z-$_-$o),$d):$z==$y?do{$s#\n x($y-$_),$d}:$y-$_>$z?do{$s x$z\n ,$v}:$y-$_==$z?do{$s x($y-$_),\n $c}:do{$s x($y-$_),$d}}say$c,\n $h x$x,$c}cube @ARGV>2?@ARGV\n [0..2]:map{rand($_)}20,10,8\n"
  },
  {
    "path": "Math/cyclotomic_factorization_method.pl",
    "content": "#!/usr/bin/perl\r\n\r\n# Author: Trizen\r\n# Date: 22 May 2022\r\n# https://github.com/trizen\r\n\r\n# A variant of the Cyclotomic factorization method.\r\n\r\n# See also:\r\n#   https://www.ams.org/journals/mcom/1989-52-185/S0025-5718-1989-0947467-1/S0025-5718-1989-0947467-1.pdf\r\n\r\nuse 5.020;\r\nuse strict;\r\nuse warnings;\r\n\r\nuse Math::GMPz;\r\nuse ntheory qw(:all);\r\nuse POSIX qw(ULONG_MAX);\r\n\r\nuse experimental qw(signatures);\r\n\r\nsub cyclotomic_factor ($m, $n = 3628800, $upto = 100) {\r\n\r\n    $n = Math::GMPz->new(\"$n\");\r\n    $m = Math::GMPz->new(\"$m\");\r\n\r\n    Math::GMPz::Rmpz_sgn($m) || return 1;\r\n\r\n    # n must be >= 0\r\n    (Math::GMPz::Rmpz_sgn($n) || return 1) > 0\r\n      or return 1;\r\n\r\n    return 1 if (Math::GMPz::Rmpz_cmp_ui($m, 1) == 0);\r\n\r\n    my @factor_exp = factor_exp($n);\r\n\r\n    # Generate the squarefree divisors of n, along\r\n    # with the number of prime factors of each divisor\r\n    my @sd;\r\n    foreach my $pe (@factor_exp) {\r\n        my ($p) = @$pe;\r\n\r\n        $p =\r\n          ($p < ULONG_MAX)\r\n          ? Math::GMPz::Rmpz_init_set_ui($p)\r\n          : Math::GMPz::Rmpz_init_set_str(\"$p\", 10);\r\n\r\n        push @sd, map { [$_->[0] * $p, $_->[1] + 1] } @sd;\r\n        push @sd, [$p, 1];\r\n    }\r\n\r\n    push @sd, [Math::GMPz->new(1), 0];\r\n\r\n    my $prod = Math::GMPz::Rmpz_init_set_ui(1);\r\n    my $g    = Math::GMPz::Rmpz_init();\r\n    my $x    = Math::GMPz::Rmpz_init_set_ui(2);\r\n\r\n    foreach my $k (2 .. $upto) {\r\n        my $x = Math::GMPz::Rmpz_init_set_ui($k);\r\n\r\n        foreach my $pair (@sd) {\r\n            my ($d, $c) = @$pair;\r\n\r\n            my $base = Math::GMPz::Rmpz_init();\r\n            Math::GMPz::Rmpz_divexact($base, $n, $d);\r\n            Math::GMPz::Rmpz_powm($base, $x, $base, $m);    # x^(n/d) mod m\r\n            Math::GMPz::Rmpz_sub_ui($base, $base, 1);\r\n\r\n            Math::GMPz::Rmpz_gcd($g, $base, $m);\r\n\r\n            if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {\r\n                last if (Math::GMPz::Rmpz_cmp($g, $m) == 0);\r\n                return $g;\r\n            }\r\n\r\n            if ($c % 2 == 1) {\r\n                Math::GMPz::Rmpz_invert($base, $base, $m);\r\n            }\r\n\r\n            Math::GMPz::Rmpz_mul($prod, $prod, $base);\r\n            Math::GMPz::Rmpz_mod($prod, $prod, $m);\r\n        }\r\n    }\r\n\r\n    return 1;\r\n}\r\n\r\nsay cyclotomic_factor(Math::GMPz->new(2)**64 + 1,  40320, 100);     #=> 274177\r\nsay cyclotomic_factor(Math::GMPz->new(2)**128 - 1, 40320, 100);     #=> 18446744073709551615\r\n"
  },
  {
    "path": "Math/cyclotomic_factorization_method_2.pl",
    "content": "#!/usr/bin/perl\r\n\r\n# Author: Trizen\r\n# Date: 23 May 2022\r\n# https://github.com/trizen\r\n\r\n# A variant of the Cyclotomic factorization method.\r\n\r\n# See also:\r\n#   https://www.ams.org/journals/mcom/1989-52-185/S0025-5718-1989-0947467-1/S0025-5718-1989-0947467-1.pdf\r\n\r\nuse 5.020;\r\nuse strict;\r\nuse warnings;\r\n\r\nuse Math::GMPz;\r\nuse ntheory qw(:all);\r\nuse POSIX qw(ULONG_MAX);\r\n\r\nuse experimental qw(signatures);\r\n\r\nsub cyclotomic_factor ($n, @bases) {\r\n\r\n    $n = Math::GMPz->new(\"$n\");\r\n\r\n    Math::GMPz::Rmpz_cmp_ui($n, 1) > 0 or return;\r\n\r\n    if (@bases) {\r\n        @bases = map { Math::GMPz->new(\"$_\") } @bases;\r\n    }\r\n    else {\r\n        @bases = map { Math::GMPz->new($_) } (2 .. logint($n, 2));\r\n    }\r\n\r\n    my $cyclotomicmod = sub ($n, $x, $m) {\r\n\r\n        my @factor_exp = factor_exp($n);\r\n\r\n        # Generate the squarefree divisors of n, along\r\n        # with the number of prime factors of each divisor\r\n        my @sd;\r\n        foreach my $pe (@factor_exp) {\r\n            my ($p) = @$pe;\r\n            push @sd, map { [$_->[0] * $p, $_->[1] + 1] } @sd;\r\n            push @sd, [$p, 1];\r\n        }\r\n\r\n        push @sd, [Math::GMPz::Rmpz_init_set_ui(1), 0];\r\n\r\n        my $prod = Math::GMPz::Rmpz_init_set_ui(1);\r\n\r\n        foreach my $pair (@sd) {\r\n            my ($d, $c) = @$pair;\r\n\r\n            my $base = Math::GMPz::Rmpz_init();\r\n            my $exp  = CORE::int($n / $d);\r\n\r\n            Math::GMPz::Rmpz_powm_ui($base, $x, $exp, $m);    # x^(n/d) mod m\r\n            Math::GMPz::Rmpz_sub_ui($base, $base, 1);\r\n\r\n            if ($c % 2 == 1) {\r\n                Math::GMPz::Rmpz_invert($base, $base, $m) || return $base;\r\n            }\r\n\r\n            Math::GMPz::Rmpz_mul($prod, $prod, $base);\r\n            Math::GMPz::Rmpz_mod($prod, $prod, $m);\r\n        }\r\n\r\n        $prod;\r\n    };\r\n\r\n    my @factors;\r\n    state $g = Math::GMPz::Rmpz_init_nobless();\r\n\r\n  OUTER: foreach my $x (@bases) {\r\n        my $limit = 1 + logint($n, $x);\r\n\r\n        foreach my $k (3 .. $limit) {\r\n            my $c = $cyclotomicmod->($k, $x, $n);\r\n\r\n            Math::GMPz::Rmpz_gcd($g, $n, $c);\r\n            if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0 and Math::GMPz::Rmpz_cmp($g, $n) < 0) {\r\n\r\n                my $valuation = Math::GMPz::Rmpz_remove($n, $n, $g);\r\n                push(@factors, (Math::GMPz::Rmpz_init_set($g)) x $valuation);\r\n\r\n                if (Math::GMPz::Rmpz_cmp_ui($n, 1) == 0 or is_prob_prime($n)) {\r\n                    last OUTER;\r\n                }\r\n            }\r\n        }\r\n    }\r\n\r\n    if (Math::GMPz::Rmpz_cmp_ui($n, 1) > 0) {\r\n        push @factors, $n;\r\n    }\r\n\r\n    @factors = sort { Math::GMPz::Rmpz_cmp($a, $b) } @factors;\r\n    return @factors;\r\n}\r\n\r\nsay join ' * ', cyclotomic_factor(Math::GMPz->new(2)**120 + 1);\r\nsay join ' * ', cyclotomic_factor(Math::GMPz->new(2)**128 - 1);\r\nsay join ' * ', cyclotomic_factor(((Math::GMPz->new(10)**258 - 1) / 9 - Math::GMPz->new(10)**(258 >> 1) - 1), 10);\r\n\r\n__END__\r\n257 * 65281 * 4278255361 * 18518800563924107521\r\n3 * 5 * 17 * 257 * 65537 * 4294967297 * 18446744073709551617\r\n10 * 11 * 11 * 91 * 101 * 10001 * 100000001 * 10000000000000001 * 100000000000000000000000000000001 * 909090909090909090909090909090909090909091 * 10000000000000000000000000000000000000000000000000000000000000001 * 1098901098901098901098901098901098901098900989010989010989010989010989010989010989011\r\n"
  },
  {
    "path": "Math/cyclotomic_polynomial.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 08 July 2018\n# https://github.com/trizen\n\n# Efficient formula for computing the n-th cyclotomic polynomial.\n\n# Formula:\n#   cyclotomic(n, x) = Prod_{d|n} (x^(n/d) - 1)^moebius(d)\n\n# Optimization: by generating only the squarefree divisors of n and keeping track of\n# the number of prime factors of each divisor, we do not need the Moebius function.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Cyclotomic_polynomial\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse Math::AnyNum qw(:overload prod);\n\nsub cyclotomic_polynomial {\n    my ($n, $x) = @_;\n\n    # Special case for x = 1: cyclotomic(n, 1) is A020500.\n    if ($x == 1) {\n        my $k = is_prime_power($n) || return 1;\n        my $p = rootint($n, $k);\n        return $p;\n    }\n\n    # Special case for x = -1: cyclotomic(n, -1) is A020513.\n    if ($x == -1) {\n        ($n % 2 == 0) || return 1;\n        my $k = is_prime_power($n >> 1) || return 1;\n        my $p = rootint($n >> 1, $k);\n        return $p;\n    }\n\n    # Generate the squarefree divisors of n, along\n    # with the number of prime factors of each divisor\n    my @d;\n    foreach my $p (map { $_->[0] } factor_exp($n)) {\n        push @d, map { [$_->[0] * $p, $_->[1] + 1] } @d;\n        push @d, [$p, 1];\n    }\n\n    push @d, [1, 0];\n\n    # Multiply the terms\n    prod(map { ($x**($n / $_->[0]) - 1)**((-1)**$_->[1]) } @d);\n}\n\nsay cyclotomic_polynomial(5040, 4 / 3);\nsay join(', ', map { cyclotomic_polynomial($_, 2) } 1 .. 20);    # https://oeis.org/A019320\n"
  },
  {
    "path": "Math/definite_integral_numerical_approximation.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 21 February 2018\n# https://github.com/trizen\n\n# Simple numerical approximation for definite integrals.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nsub integral ($from, $to, $expr, $dx = 0.0001) {\n    my $sum = 0;\n\n    for (my $x = $from ; $x <= $to ; $x += $dx) {\n        $sum += $expr->($x) * $dx;\n    }\n\n    return $sum;\n}\n\nsay integral(0, atan2(0, -1), sub ($x) { sin($x) });              # 1.99999999867257\nsay integral(2,  100, sub ($x) { 1 / log($x) });                  # 29.0810390821689\nsay integral(-3, 5,   sub ($x) { 10 * $x**3 + $x * cos($x) });    # 1355.97975127903\n"
  },
  {
    "path": "Math/dickson_linear_forms_prime_sieve.pl",
    "content": "#!/usr/bin/perl\n\n# Sieve for linear forms primes of the form `a_1*m + b_1`, `a_2*m + b_2`, ..., `a_k*m + b_k`.\n# Inspired by the PARI program by David A. Corneth from OEIS A372238.\n\n# See also:\n#   https://oeis.org/A088250\n#   https://oeis.org/A318646\n#   https://oeis.org/A372238/a372238.gp.txt\n#   https://en.wikipedia.org/wiki/Dickson%27s_conjecture\n\nuse 5.036;\nuse ntheory     qw(:all);\nuse List::Util  qw(all);\nuse Time::HiRes qw(time);\n\nsub isrem($m, $p, $terms) {\n\n    foreach my $k (@$terms) {\n        my $t = $k->[0] * $m + $k->[1];\n        if ($t % $p == 0 and $t > $p) {\n            return;\n        }\n    }\n\n    return 1;\n}\n\nsub remaindersmodp($p, $terms) {\n    grep { isrem($_, $p, $terms) } (0 .. $p - 1);\n}\n\nsub remainders_for_primes($primes, $terms) {\n\n    my $res = [[0, 1]];\n    my $M   = 1;\n\n    foreach my $p (@$primes) {\n\n        my @rems = remaindersmodp($p, $terms);\n\n        if (scalar(@rems) == $p) {\n            next;    # skip trivial primes\n        }\n\n        if (!@rems) {\n            @rems = (0);\n        }\n\n        my @nres;\n        foreach my $r (@$res) {\n            foreach my $rem (@rems) {\n                push @nres, [chinese($r, [$rem, $p]), lcm($p, $r->[1])];\n            }\n        }\n\n        $res = \\@nres;\n        $M *= $p;\n    }\n\n    return ($M, [sort { $a <=> $b } map { $_->[0] } @$res]);\n}\n\nsub deltas ($integers) {\n\n    my @deltas;\n    my $prev = 0;\n\n    foreach my $n (@$integers) {\n        push @deltas, $n - $prev;\n        $prev = $n;\n    }\n\n    shift(@deltas);\n    return \\@deltas;\n}\n\nsub linear_form_primes($terms, $maxp = nth_prime(scalar(@$terms))) {\n\n    my @primes = @{primes($maxp)};\n\n    my ($M, $r) = remainders_for_primes(\\@primes, $terms);\n    my @d = @{deltas($r)};\n\n    while (@d and $d[0] == 0) {\n        shift @d;\n    }\n\n    push @d, $r->[0] + $M - $r->[-1];\n\n    my $m      = $r->[0];\n    my $d_len  = scalar(@d);\n    my $t0     = time;\n    my $prev_m = $m;\n    my $n      = scalar(@$terms);\n\n    for (my $j = 0 ; ; ++$j) {\n\n        my $ok = 1;\n        foreach my $k (@$terms) {\n            if (!is_prime($k->[0] * $m + $k->[1])) {\n                $ok = 0;\n                last;\n            }\n        }\n\n        if ($ok) {\n            return $m;\n        }\n\n        if ($j % 1e7 == 0 and $j > 0) {\n            my $tdelta = time - $t0;\n            say \"Searching for a($n) with m = $m\";\n            say \"Performance: \", (($m - $prev_m) / 1e9) / $tdelta, \" * 10^9 terms per second\";\n            $t0     = time;\n            $prev_m = $m;\n        }\n\n        $m += $d[$j % $d_len];\n    }\n}\n\nforeach my $n (1 .. 10) {\n    my @terms = map { [$_, 1] } (1 .. $n);\n    my $m     = linear_form_primes(\\@terms);\n    say \"a($n) = $m\";\n}\n\n__END__\na(1) = 1\na(2) = 1\na(3) = 2\na(4) = 330\na(5) = 10830\na(6) = 25410\na(7) = 512820\na(8) = 512820\na(9) = 12960606120\na(10) = 434491727670\n"
  },
  {
    "path": "Math/dickson_linear_forms_prime_sieve_in_range.pl",
    "content": "#!/usr/bin/perl\n\n# Sieve for linear forms primes of the form `a_1*m + b_1`, `a_2*m + b_2`, ..., `a_k*m + b_k`.\n# Inspired by the PARI program by David A. Corneth from OEIS A372238.\n\n# See also:\n#   https://oeis.org/A088250\n#   https://oeis.org/A318646\n#   https://oeis.org/A372238/a372238.gp.txt\n#   https://en.wikipedia.org/wiki/Dickson%27s_conjecture\n\nuse 5.036;\nuse ntheory     qw(:all);\nuse Time::HiRes qw(time);\nuse Test::More tests => 36;\n\nsub isrem($m, $p, $terms) {\n\n    foreach my $k (@$terms) {\n        my $t = $k->[0] * $m + $k->[1];\n        if ($t % $p == 0 and $t > $p) {     # FIXME: the second condition can be removed (see version 2)\n            return;\n        }\n    }\n\n    return 1;\n}\n\nsub remaindersmodp($p, $terms) {\n    grep { isrem($_, $p, $terms) } (0 .. $p - 1);\n}\n\nsub remainders_for_primes($primes, $terms) {\n\n    my $res = [[0, 1]];\n    my $M   = 1;\n\n    foreach my $p (@$primes) {\n\n        my @rems = remaindersmodp($p, $terms);\n\n        if (scalar(@rems) == $p) {\n            next;    # skip trivial primes\n        }\n\n        my @nres;\n        foreach my $r (@$res) {\n            foreach my $rem (@rems) {\n                push @nres, [chinese($r, [$rem, $p]), lcm($p, $r->[1])];\n            }\n        }\n\n        $M *= $p;\n        $res = \\@nres;\n    }\n\n    return ($M, [sort { $a <=> $b } map { $_->[0] } @$res]);\n}\n\nsub deltas ($integers) {\n\n    my @deltas;\n    my $prev = 0;\n\n    foreach my $n (@$integers) {\n        push @deltas, $n - $prev;\n        $prev = $n;\n    }\n\n    shift(@deltas);\n    return \\@deltas;\n}\n\nsub linear_form_primes_in_range($A, $B, $terms) {\n\n    return [] if ($A > $B);\n\n    my $terms_len  = scalar(@$terms);\n    my $range_size = int(exp(LambertW(log($B - $A + 1))));\n\n    my $max_p  = nth_prime(vecmin($terms_len, $range_size));\n    my @primes = @{primes($max_p)};\n\n    my ($M, $r) = remainders_for_primes(\\@primes, $terms);\n    my @d = @{deltas($r)};\n\n    while (@d and $d[0] == 0) {\n        shift @d;\n    }\n\n    push @d, $r->[0] + $M - $r->[-1];\n\n    my $m      = $r->[0];\n    my $d_len  = scalar(@d);\n    my $t0     = time;\n    my $prev_m = $m;\n    my $d_sum  = vecsum(@d);\n\n    $m += $d_sum * divint($A, $d_sum);\n\n    my $j = 0;\n\n    while ($m < $A) {\n        $m += $d[$j++ % $d_len];\n    }\n\n    my @arr;\n\n    while (1) {\n        my $ok = 1;\n        foreach my $k (@$terms) {\n            if (!is_prime($k->[0] * $m + $k->[1])) {\n                $ok = 0;\n                last;\n            }\n        }\n\n        if ($ok) {\n            push @arr, $m;\n        }\n\n        if ($j % 1e7 == 0 and $j > 0) {\n            my $tdelta = time - $t0;\n            say \"Searching with m = $m\";\n            say \"Performance: \", (($m - $prev_m) / 1e9) / $tdelta, \" * 10^9 terms per second\";\n            $t0     = time;\n            $prev_m = $m;\n        }\n\n        $m += $d[$j++ % $d_len];\n        last if ($m > $B);\n    }\n\n    return \\@arr;\n}\n\nis_deeply(linear_form_primes_in_range(1, 41, [[1, 41]]),                                           [2, 6, 12, 18, 20, 26, 30, 32, 38]);\nis_deeply(linear_form_primes_in_range(1, 50, [[1, 1]]),                                            [1, 2, 4, 6, 10, 12, 16, 18, 22, 28, 30, 36, 40, 42, 46]);\nis_deeply(linear_form_primes_in_range(1, 100, [[1, 1], [2, 1]]),                                   [1, 2, 6, 18, 30, 36, 78, 96]);\nis_deeply(linear_form_primes_in_range(1, 1000, [[1, 1], [2, 1], [3, 1]]),                          [2, 6, 36, 210, 270, 306, 330, 336, 600, 726]);\nis_deeply(linear_form_primes_in_range(1, 10000, [[1, 1], [2, 1], [3, 1], [4, 1]]),                 [330, 1530, 3060, 4260, 4950, 6840]);\nis_deeply(linear_form_primes_in_range(1, 12000, [[1, 1], [2, 1], [3, 1], [4, 1], [5, 1]]),         [10830]);\nis_deeply(linear_form_primes_in_range(9538620, 9993270, [[1, 1], [2, 1], [3, 1], [4, 1], [5, 1]]), [9538620, 9780870, 9783060, 9993270]);\nis_deeply(linear_form_primes_in_range(9538620 + 1, 9993270, [[1, 1], [2, 1], [3, 1], [4, 1], [5, 1]]), [9780870, 9783060, 9993270]);\n\nis_deeply(linear_form_primes_in_range(1, 1000, [[1, -1], [2, -1], [3, -1]]),           [4, 6, 24, 30, 84, 90, 174, 234, 240, 294, 420, 660, 954]);\nis_deeply(linear_form_primes_in_range(1, 10000, [[1, -1], [2, -1], [3, -1], [4, -1]]), [6, 90, 1410, 1890]);\nis_deeply(linear_form_primes_in_range(1, 500, [[2, -1], [4, -1], [6, -1]]),            [2, 3, 12, 15, 42, 45, 87, 117, 120, 147, 210, 330, 477]);\nis_deeply(linear_form_primes_in_range(1, 500, [[2, 1], [4, 3], [8, 7]]),               [2, 5, 20, 44, 89, 179, 254, 359]);\nis_deeply(linear_form_primes_in_range(1, 500, [[2, -1], [4, -1], [8, -1]]),            [3, 6, 21, 45, 90, 180, 255, 360]);\nis_deeply(linear_form_primes_in_range(1, 500, [[2, -1], [4, -1], [8, -1], [16, -1]]),  [3, 45, 90, 180, 255]);\nis_deeply(linear_form_primes_in_range(1, 500, [[17, 1], [23, 5]]),                     [18, 24, 66, 126, 186, 216, 378, 384, 426]);\n\n#<<<\nis_deeply(linear_form_primes_in_range(1, 500, [[17, 4], [15, -8], [19, 2]]), [5, 9, 11, 65, 75, 105, 125, 159, 191, 221, 231, 291, 341, 369, 419, 461, 471, 479]);\nis_deeply(linear_form_primes_in_range(1, 500, [[17, 4], [15, +8], [19, 2]]), [5, 11, 45, 65, 105, 159, 161, 189, 221, 275, 291, 299, 431, 479]);\n#>>>\n\nsub f($n, $multiple = 1, $alpha = 1) {\n\n    my @terms = map { [$multiple * $_, $alpha] } 1 .. $n;\n\n    my $A = 1;\n    my $B = 2 * $A;\n\n    while (1) {\n        my @arr = @{linear_form_primes_in_range($A, $B, \\@terms)};\n\n        if (@arr) {\n            return $arr[0];\n        }\n\n        $A = $B + 1;\n        $B = 2 * $A;\n    }\n}\n\nis_deeply([map { f($_, 1, +1) } 1 .. 8], [1, 1, 2, 330, 10830, 25410,  512820,  512820]);     # A088250\nis_deeply([map { f($_, 1, -1) } 1 .. 8], [3, 3, 4, 6,   6,     154770, 2894220, 2894220]);    # A088651\nis_deeply([map { f($_, 9, +1) } 1 .. 8], [2, 2, 4, 170, 9860,  23450,  56980,   56980]);      # A372238\nis_deeply([map { f($_, 2, -1) } 1 .. 8], [2, 2, 2, 3,   3,     77385,  1447110, 1447110]);    # A124492\nis_deeply([map { f($_, 2, +1) } 1 .. 8], [1, 1, 1, 165, 5415,  12705,  256410,  256410]);     # A071576\n\nis_deeply([map { f($_, $_, +1) } 1 .. 8], [1, 1, 2, 765,  2166, 4235,  73260,  2780085]);\nis_deeply([map { f($_, $_, -1) } 1 .. 8], [3, 2, 2, 3225, 18,   25795, 413460, 7505190]);\n\nis_deeply([map { f($_, $_, -13) } 1 .. 6], [15, 8,  6,  15,  24, 2800]);\nis_deeply([map { f($_, $_, +13) } 1 .. 6], [4,  12, 10, 90,  18, 40705]);\nis_deeply([map { f($_, $_, -23) } 1 .. 6], [25, 13, 10, 255, 6,  5]);\nis_deeply([map { f($_, $_, +23) } 1 .. 6], [6,  9,  10, 60,  48, 13300]);\n\nis_deeply([map { f($_, 1, +23) } 1 .. 6], [6, 18, 30, 210, 240, 79800]);\nis_deeply([map { f($_, 1, -23) } 1 .. 8], [25, 26, 30, 30, 30, 30, 142380, 1319010]);\n\nis_deeply([map { f($_, 1, +101) } 1 .. 6], [2,   6,   96,  180, 3990, 1683990]);\nis_deeply([map { f($_, 1, -101) } 1 .. 6], [103, 104, 104, 240, 3630, 78540]);\n\nis_deeply(linear_form_primes_in_range(1, 1e3, [[2, 1], [4, 1], [6, 1]]), [1, 3, 18, 105, 135, 153, 165, 168, 300, 363, 585, 618, 648, 765, 828]);    # A124408\nis_deeply(linear_form_primes_in_range(1, 1e4, [[2, 1], [4, 1], [6, 1], [8, 1]]),          [165, 765, 1530, 2130, 2475, 3420, 5415, 7695, 9060]);     # A124409\nis_deeply(linear_form_primes_in_range(1, 1e5, [[2, 1], [4, 1], [6, 1], [8, 1], [10, 1]]), [5415, 12705, 13020, 44370, 82950, 98280]);                # A124410\nis_deeply(linear_form_primes_in_range(1, 1e6, [[2, 1], [4, 1], [6, 1], [8, 1], [10, 1], [12, 1]]), [12705, 13020, 105525, 256410, 966840]);          # A124411\n\nsay \"\\n=> The least Chernick's \\\"universal form\\\" Carmichael number with n prime factors\";\n\nforeach my $n (3 .. 9) {\n\n    my $terms = [map { [$_, 1] } (6, 12, (map { 9 * (1 << $_) } 1 .. $n - 2))];\n\n    my $A = 1;\n    my $B = 2 * $A;\n\n    while (1) {\n        my @arr = @{linear_form_primes_in_range($A, $B, $terms)};\n\n        @arr = grep { valuation($_, 2) >= $n - 4 } @arr;\n\n        if (@arr) {\n            say \"a($n) = $arr[0]\";\n            last;\n        }\n\n        $A = $B + 1;\n        $B = 2 * $A;\n    }\n}\n\nsay \"\\n=> Smallest number k such that r*k + 1 is prime for all r = 1 to n\";\n\nforeach my $n (1 .. 9) {\n    say \"a($n) = \", f($n, 1, 1);\n}\n\n__END__\n=> The least Chernick's \"universal form\" Carmichael number with n prime factors\na(3) = 1\na(4) = 1\na(5) = 380\na(6) = 380\na(7) = 780320\na(8) = 950560\na(9) = 950560\n\n=> Smallest number k such that r*k + 1 is prime for all r = 1 to n\n\na(1) = 1\na(2) = 1\na(3) = 2\na(4) = 330\na(5) = 10830\na(6) = 25410\na(7) = 512820\na(8) = 512820\n"
  },
  {
    "path": "Math/dickson_linear_forms_prime_sieve_in_range_2.pl",
    "content": "#!/usr/bin/perl\n\n# Sieve for linear forms primes of the form `a_1*m + b_1`, `a_2*m + b_2`, ..., `a_k*m + b_k`.\n\n# See also:\n#   https://oeis.org/A088250\n#   https://oeis.org/A318646\n#   https://oeis.org/A372238/a372238.gp.txt\n#   https://en.wikipedia.org/wiki/Dickson%27s_conjecture\n\nuse utf8;\nuse 5.036;\nuse ntheory     qw(:all);\nuse Time::HiRes qw(time);\nuse Test::More tests => 36;\n\nsub remainders_mod_p($p, $terms) {\n    my @bad;    # bad[m] = 1 means m is forbidden modulo p\n\n    foreach my $pair (@$terms) {\n        my ($n, $k) = @$pair;\n\n        $n %= $p;\n        $k %= $p;\n\n        if ($n == 0) {\n\n            # Term is constant mod p\n            if ($k == 0) {\n\n                # Always 0 mod p -> no admissible residue exists\n                return ();\n            }\n            next;    # This term forbids no residue for this p\n        }\n\n        # Forbid the unique residue m ≡ -k * n^{-1} (mod p)\n        my $n_inv    = invmod($n, $p);\n        my $m_forbid = (-$k * $n_inv) % $p;\n        $bad[$m_forbid] = 1;\n    }\n\n    return grep { !$bad[$_] } 0 .. $p - 1;\n}\n\nsub combine_crt($arr, $M, $p, $S_p) {\n\n    my @res;\n    my $Minv = invmod($M % $p, $p);\n\n    foreach my $r (@$arr) {\n        my $r_mod_p = $r % $p;\n        foreach my $s (@$S_p) {\n            push @res, (((($s - $r_mod_p) % $p) * $Minv) % $p) * $M + $r;\n        }\n    }\n\n    return \\@res;\n}\n\nsub remainders_for_primes($primes) {\n\n    my $M        = 1;\n    my $residues = [0];\n\n    foreach my $pair (@$primes) {\n        my ($p, $S_p) = @$pair;\n\n        # Early return if no valid residues\n        return ($M, []) unless @$S_p;\n\n        $residues = combine_crt($residues, $M, $p, $S_p);\n        $M *= $p;\n    }\n\n    return ($M, [sort { $a <=> $b } @$residues]);\n}\n\nsub deltas ($integers) {\n\n    my @deltas;\n    my $prev = 0;\n\n    foreach my $n (@$integers) {\n        push @deltas, $n - $prev;\n        $prev = $n;\n    }\n\n    shift(@deltas);\n    return \\@deltas;\n}\n\nsub select_optimal_primes ($A, $B, $terms) {\n\n    my $range = $B - $A + 1;\n    return () if $range <= 0;\n\n    my $target_modulus = (1 + rootint($range, 5))**4;\n\n    my $M = 1;\n    my @primes;\n\n    for (my $p = 2 ; $M <= $target_modulus ; $p = next_prime($p)) {\n        my @S_p = remainders_mod_p($p, $terms);\n\n        if (scalar(@S_p) == $p) {\n            next;    # skip trivial primes\n        }\n\n        push(@primes, [$p, \\@S_p]);\n        $M *= $p;\n    }\n\n    return @primes;\n}\n\nsub linear_form_primes_in_range($A, $B, $terms) {\n\n    return [] if ($A > $B);\n    return [] if !@$terms;\n\n    # Select an optimal subset of small primes for the modular sieve\n    my @primes = select_optimal_primes($A, $B, $terms);\n    return [] unless @primes;\n\n    my ($M, $r) = remainders_for_primes(\\@primes);\n\n    # If there are no admissible residues modulo M, there can be no solutions\n    return [] if !@$r;\n\n    # Compute differences\n    my @d = @{deltas($r)};\n\n    # Remove leading zeros\n    while (@d and $d[0] == 0) {\n        shift @d;\n    }\n\n    # Add wraparound delta\n    push @d, $r->[0] + $M - $r->[-1];\n\n    my $compute_small_values = 0;\n    my $small_values_limit   = vecmin(500, $B);\n    my $original_A           = undef;\n\n    if ($A < $small_values_limit) {\n        $original_A           = $A;\n        $A                    = $small_values_limit + 1;\n        $compute_small_values = 1;\n    }\n\n    my $m      = $r->[0];\n    my $d_len  = scalar(@d);\n    my $t0     = time;\n    my $prev_m = $m;\n\n    # Jump near to the start of the range\n    $m += $M * divint($A, $M);\n\n    my $j = 0;\n\n    while ($m < $A) {\n        $m += $d[$j++ % $d_len];\n    }\n\n    my @multiples = map { $_->[0] } @$terms;\n    my @alphas    = map { $_->[1] } @$terms;\n    my @range     = (0 .. $#multiples);\n\n    my ($ok, @arr);\n\n    # Compute small values if needed\n    if ($compute_small_values) {\n        foreach my $k ($original_A .. $small_values_limit) {\n\n            $ok = 1;\n            foreach my $i (@range) {\n                if (!is_prime($multiples[$i] * $k + $alphas[$i])) {\n                    $ok = 0;\n                    last;\n                }\n            }\n\n            $ok && push @arr, $k;\n        }\n    }\n\n    while ($m <= $B) {\n\n        $ok = 1;\n        foreach my $k (@range) {\n            if (!is_prime($multiples[$k] * $m + $alphas[$k])) {\n                $ok = 0;\n                last;\n            }\n        }\n\n        if ($ok) {\n            push @arr, $m;\n        }\n\n        if ($j % 1e7 == 0 and $j > 0) {\n            my $tdelta = time - $t0;\n            say \"Searching with m = $m\";\n            say \"Performance: \", (($m - $prev_m) / 1e9) / $tdelta, \" * 10^9 terms per second\";\n            $t0     = time;\n            $prev_m = $m;\n        }\n\n        $m += $d[$j++ % $d_len];\n    }\n\n    return \\@arr;\n}\n\nis_deeply(linear_form_primes_in_range(1, 41, [[1, 41]]),                                           [2, 6, 12, 18, 20, 26, 30, 32, 38]);\nis_deeply(linear_form_primes_in_range(1, 50, [[1, 1]]),                                            [1, 2, 4, 6, 10, 12, 16, 18, 22, 28, 30, 36, 40, 42, 46]);\nis_deeply(linear_form_primes_in_range(1, 100, [[1, 1], [2, 1]]),                                   [1, 2, 6, 18, 30, 36, 78, 96]);\nis_deeply(linear_form_primes_in_range(1, 1000, [[1, 1], [2, 1], [3, 1]]),                          [2, 6, 36, 210, 270, 306, 330, 336, 600, 726]);\nis_deeply(linear_form_primes_in_range(1, 10000, [[1, 1], [2, 1], [3, 1], [4, 1]]),                 [330, 1530, 3060, 4260, 4950, 6840]);\nis_deeply(linear_form_primes_in_range(1, 12000, [[1, 1], [2, 1], [3, 1], [4, 1], [5, 1]]),         [10830]);\nis_deeply(linear_form_primes_in_range(9538620, 9993270, [[1, 1], [2, 1], [3, 1], [4, 1], [5, 1]]), [9538620, 9780870, 9783060, 9993270]);\nis_deeply(linear_form_primes_in_range(9538620 + 1, 9993270, [[1, 1], [2, 1], [3, 1], [4, 1], [5, 1]]), [9780870, 9783060, 9993270]);\n\nis_deeply(linear_form_primes_in_range(1, 1000, [[1, -1], [2, -1], [3, -1]]),           [4, 6, 24, 30, 84, 90, 174, 234, 240, 294, 420, 660, 954]);\nis_deeply(linear_form_primes_in_range(1, 10000, [[1, -1], [2, -1], [3, -1], [4, -1]]), [6, 90, 1410, 1890]);\nis_deeply(linear_form_primes_in_range(1, 500, [[2, -1], [4, -1], [6, -1]]),            [2, 3, 12, 15, 42, 45, 87, 117, 120, 147, 210, 330, 477]);\nis_deeply(linear_form_primes_in_range(1, 500, [[2, 1], [4, 3], [8, 7]]),               [2, 5, 20, 44, 89, 179, 254, 359]);\nis_deeply(linear_form_primes_in_range(1, 500, [[2, -1], [4, -1], [8, -1]]),            [3, 6, 21, 45, 90, 180, 255, 360]);\nis_deeply(linear_form_primes_in_range(1, 500, [[2, -1], [4, -1], [8, -1], [16, -1]]),  [3, 45, 90, 180, 255]);\nis_deeply(linear_form_primes_in_range(1, 500, [[17, 1], [23, 5]]),                     [18, 24, 66, 126, 186, 216, 378, 384, 426]);\n\n#<<<\nis_deeply(linear_form_primes_in_range(1, 500, [[17, 4], [15, -8], [19, 2]]), [5, 9, 11, 65, 75, 105, 125, 159, 191, 221, 231, 291, 341, 369, 419, 461, 471, 479]);\nis_deeply(linear_form_primes_in_range(1, 500, [[17, 4], [15, +8], [19, 2]]), [5, 11, 45, 65, 105, 159, 161, 189, 221, 275, 291, 299, 431, 479]);\n#>>>\n\nsub f($n, $multiple = 1, $alpha = 1) {\n\n    my @terms = map { [$multiple * $_, $alpha] } 1 .. $n;\n\n    my $A = 1;\n    my $B = 2 * $A;\n\n    while (1) {\n        my @arr = @{linear_form_primes_in_range($A, $B, \\@terms)};\n\n        if (@arr) {\n            return $arr[0];\n        }\n\n        $A = $B + 1;\n        $B = 2 * $A;\n    }\n}\n\nis_deeply([map { f($_, 1, +1) } 1 .. 8], [1, 1, 2, 330, 10830, 25410,  512820,  512820]);     # A088250\nis_deeply([map { f($_, 1, -1) } 1 .. 8], [3, 3, 4, 6,   6,     154770, 2894220, 2894220]);    # A088651\nis_deeply([map { f($_, 9, +1) } 1 .. 8], [2, 2, 4, 170, 9860,  23450,  56980,   56980]);      # A372238\nis_deeply([map { f($_, 2, -1) } 1 .. 8], [2, 2, 2, 3,   3,     77385,  1447110, 1447110]);    # A124492\nis_deeply([map { f($_, 2, +1) } 1 .. 8], [1, 1, 1, 165, 5415,  12705,  256410,  256410]);     # A071576\n\nis_deeply([map { f($_, $_, +1) } 1 .. 8], [1, 1, 2, 765,  2166, 4235,  73260,  2780085]);\nis_deeply([map { f($_, $_, -1) } 1 .. 8], [3, 2, 2, 3225, 18,   25795, 413460, 7505190]);\n\nis_deeply([map { f($_, $_, -13) } 1 .. 6], [15, 8,  6,  15,  24, 2800]);\nis_deeply([map { f($_, $_, +13) } 1 .. 6], [4,  12, 10, 90,  18, 40705]);\nis_deeply([map { f($_, $_, -23) } 1 .. 6], [25, 13, 10, 255, 6,  5]);\nis_deeply([map { f($_, $_, +23) } 1 .. 6], [6,  9,  10, 60,  48, 13300]);\n\nis_deeply([map { f($_, 1, +23) } 1 .. 6], [6, 18, 30, 210, 240, 79800]);\nis_deeply([map { f($_, 1, -23) } 1 .. 8], [25, 26, 30, 30, 30, 30, 142380, 1319010]);\n\nis_deeply([map { f($_, 1, +101) } 1 .. 6], [2,   6,   96,  180, 3990, 1683990]);\nis_deeply([map { f($_, 1, -101) } 1 .. 6], [103, 104, 104, 240, 3630, 78540]);\n\nis_deeply(linear_form_primes_in_range(1, 1e3, [[2, 1], [4, 1], [6, 1]]), [1, 3, 18, 105, 135, 153, 165, 168, 300, 363, 585, 618, 648, 765, 828]);    # A124408\nis_deeply(linear_form_primes_in_range(1, 1e4, [[2, 1], [4, 1], [6, 1], [8, 1]]),          [165, 765, 1530, 2130, 2475, 3420, 5415, 7695, 9060]);     # A124409\nis_deeply(linear_form_primes_in_range(1, 1e5, [[2, 1], [4, 1], [6, 1], [8, 1], [10, 1]]), [5415, 12705, 13020, 44370, 82950, 98280]);                # A124410\nis_deeply(linear_form_primes_in_range(1, 1e6, [[2, 1], [4, 1], [6, 1], [8, 1], [10, 1], [12, 1]]), [12705, 13020, 105525, 256410, 966840]);          # A124411\n\nsay \"\\n=> The least Chernick's \\\"universal form\\\" Carmichael number with n prime factors\";\n\nforeach my $n (3 .. 9) {\n\n    my $terms = [map { [$_, 1] } (6, 12, (map { 9 * (1 << $_) } 1 .. $n - 2))];\n\n    my $A = 1;\n    my $B = 2 * $A;\n\n    while (1) {\n        my @arr = @{linear_form_primes_in_range($A, $B, $terms)};\n\n        @arr = grep { valuation($_, 2) >= $n - 4 } @arr;\n\n        if (@arr) {\n            say \"a($n) = $arr[0]\";\n            last;\n        }\n\n        $A = $B + 1;\n        $B = 2 * $A;\n    }\n}\n\nsay \"\\n=> Smallest number k such that r*k + 1 is prime for all r = 1 to n\";\n\nforeach my $n (1 .. 10) {\n    say \"a($n) = \", f($n, 1, 1);\n}\n\n__END__\n=> The least Chernick's \"universal form\" Carmichael number with n prime factors\na(3) = 1\na(4) = 1\na(5) = 380\na(6) = 380\na(7) = 780320\na(8) = 950560\n\n=> Smallest number k such that r*k + 1 is prime for all r = 1 to n\n\na(1) = 1\na(2) = 1\na(3) = 2\na(4) = 330\na(5) = 10830\na(6) = 25410\na(7) = 512820\na(8) = 512820\na(9) = 12960606120\na(10) = 434491727670\n"
  },
  {
    "path": "Math/difference_of_k_powers.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 28 April 2017\n# https://github.com/trizen\n\n# Find the smallest representations for natural numbers as the difference of some k power.\n\n# Example:\n#   781 =  4^5 - 3^5\n#   992 = 10^3 - 2^3\n#   999 = 32^2 - 5^2\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(root ceil log2);\n\nOUTER: foreach my $n (1 .. 1000) {\n    foreach my $i (2 .. ceil(log2($n))) {\n        my $s = ceil(root($n, $i));\n        foreach my $k (0 .. $s) {\n            if ($s**$i - $k**$i == $n) {\n                say \"$n = $s^$i - $k^$i\";\n                next OUTER;\n            }\n        }\n    }\n}\n"
  },
  {
    "path": "Math/difference_of_powers_factorization_method.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 03 July 2019\n# Edit: 22 March 2022\n# https://github.com/trizen\n\n# A simple factorization method for numbers that can be expressed as a difference of powers.\n\n# Very effective for numbers of the form:\n#\n#   n^k - 1\n#\n# where k has many divisors.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Math::GMPz;\nuse ntheory qw(divisors rootint logint is_power gcd vecprod powint);\n\nuse constant {\n              MIN_FACTOR => 1,    # ignore small factors\n              LOG_BRANCH => 0,    # true to use the log branch in addition to the root branch\n             };\n\nsub diff_power_factorization ($n, $verbose = 0) {\n\n    if (ref($n) ne 'Math::GMPz') {\n        $n = Math::GMPz->new(\"$n\");\n    }\n\n    my $orig = $n;\n    my @diff_powers_params;\n\n    my $diff_powers = sub ($r1, $e1, $r2, $e2) {\n        my @factors;\n\n        my @divs1 = divisors($e1);\n        my @divs2 = divisors($e2);\n\n        foreach my $d1 (@divs1) {\n            my $x = $r1**$d1;\n            foreach my $d2 (@divs2) {\n                my $y = $r2**$d2;\n                foreach my $j (1, -1) {\n\n                    my $t = $x - $j * $y;\n                    my $g = gcd($t, $n);\n\n                    if ($g > MIN_FACTOR and $g < $n) {\n                        while ($n % $g == 0) {\n                            $n /= $g;\n                            push @factors, $g;\n                        }\n                    }\n                }\n            }\n        }\n\n        sort { $a <=> $b } @factors;\n    };\n\n    my $diff_power_check = sub ($r1, $e1) {\n\n        my $u  = $r1**$e1;\n        my $dx = abs($u - $n);\n\n        if ($dx >= 1 and Math::GMPz::Rmpz_perfect_power_p($dx)) {\n\n            my $e2 = ($dx == 1) ? 1 : is_power($dx);\n            my $r2 = Math::GMPz->new(rootint($dx, $e2));\n\n            if ($verbose) {\n                if ($u > $n) {\n                    say \"[*] Difference of powers detected: \", sprintf(\"%s^%s - %s^%s\", $r1, $e1, $r2, $e2);\n                }\n                else {\n                    say \"[*] Sum of powers detected: \", sprintf(\"%s^%s + %s^%s\", $r1, $e1, $r2, $e2);\n                }\n            }\n\n            push @diff_powers_params, [$r1, $e1, $r2, $e2];\n        }\n    };\n\n    # Sum and difference of powers of the form a^k ± b^k, where a and b are large.\n    foreach my $e1 (reverse 2 .. logint($n, 2)) {\n\n        my $t = Math::GMPz->new(rootint($n, $e1));\n\n        $diff_power_check->($t,     $e1);    # sum of powers\n        $diff_power_check->($t + 1, $e1);    # difference of powers\n    }\n\n    # Sum and difference of powers of the form a^k ± b^k, where a and b are small.\n    if (LOG_BRANCH) {\n        foreach my $r1 (2 .. logint($n, 2)) {\n\n            my $t = logint($n, $r1);\n\n            $diff_power_check->(Math::GMPz->new($r1), $t);        # sum of powers\n            $diff_power_check->(Math::GMPz->new($r1), $t + 1);    # difference of powers\n        }\n\n        my %seen_param;\n        @diff_powers_params = grep { !$seen_param{join(' ', @$_)}++ } @diff_powers_params;\n    }\n\n    my @factors;\n\n    foreach my $fp (@diff_powers_params) {\n        push @factors, $diff_powers->(@$fp);\n    }\n\n    push @factors, $orig / vecprod(@factors);\n    return sort { $a <=> $b } @factors;\n}\n\nif (@ARGV) {\n    say join ', ', diff_power_factorization($ARGV[0], 1);\n    exit;\n}\n\n# Large roots\nsay join ' * ', diff_power_factorization(powint(1009,     24) + powint(29,  12));\nsay join ' * ', diff_power_factorization(powint(1009,     24) - powint(29,  12));\nsay join ' * ', diff_power_factorization(powint(59388821, 12) - powint(151, 36));\n\nsay '-' x 80;\n\n# Small roots\nsay join ' * ', diff_power_factorization(powint(2,  256) - 1);\nsay join ' * ', diff_power_factorization(powint(10, 120) + 1);\nsay join ' * ', diff_power_factorization(powint(10, 120) - 1);\nsay join ' * ', diff_power_factorization(powint(10, 120) - 25);\nsay join ' * ', diff_power_factorization(powint(10, 105) - 1);\nsay join ' * ', diff_power_factorization(powint(10, 105) + 1);\nsay join ' * ', diff_power_factorization(powint(10, 120) - 2134 * 2134);\n\n__END__\n2 * 537154643295831327753001 * 1154140443257087164049583013000044736320575461201\n6 * 6 * 13 * 19 * 31 * 37 * 140 * 33937 * 36359 * 45120343 * 14006607073 * 1036518447751 * 1074309285719975471632201\n3 * 3 * 10 * 12 * 13 * 14 * 19 * 61 * 1745327 * 5594587 * 28145554676761 * 85497773607889 * 1769442985679221 * 203250599010814323919992393181\n--------------------------------------------------------------------------------\n3 * 5 * 17 * 257 * 65537 * 4294967297 * 18446744073709551617 * 340282366920938463463374607431768211457\n100000001 * 9999999900000001 * 99999999000000009999999900000001 * 10000000099999999999999989999999899999999000000000000000100000001\n3 * 9 * 11 * 37 * 91 * 101 * 9091 * 9901 * 10001 * 11111 * 90090991 * 99009901 * 99990001 * 109889011 * 9999000099990001 * 10099989899000101 * 100009999999899989999000000010001\n3 * 5 * 5 * 29 * 2298850574712643678160919540229885057471264367816091954023 * 199999999999999999999999999999999999999999999999999999999999\n9 * 111 * 11111 * 1111111 * 90090991 * 900900990991 * 900009090090909909099991 * 1109988789001111109989898989900111110998878900111\n11 * 91 * 9091 * 909091 * 769223077 * 156985855573 * 1099988890111109888900011 * 910009191000909089989898989899909091000919100091\n3 * 7 * 7 * 36 * 61 * 167280026764804282368685178989628638340582134493141518903 * 18518518518518518518518518518518518518518518518518518518479\n"
  },
  {
    "path": "Math/difference_of_three_squares_solutions.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 11 August 2017\n# Edit: 26 October 2017\n# https://github.com/trizen\n\n# An efficient algorithm for finding solutions to the equation:\n#\n#   x^2 - (x - a)^2 - (x - 2*a)^2 = n\n#\n# where only `n` is known.\n\n# This algorithm uses the divisors of `n` to generate all the positive integer solutions.\n\n# See also:\n#   https://projecteuler.net/problem=135\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(divisors);\n\nsub difference_of_three_squares_solutions {\n    my ($n) = @_;\n\n    my @divisors = divisors($n);\n\n    my @solutions;\n    foreach my $divisor (@divisors) {\n\n        last if $divisor > sqrt($n);\n\n        my $p = $divisor;\n        my $q = $n / $divisor;\n        my $k = $q + $p;\n\n        ($k % 4 == 0) ? ($k >>= 2) : next;\n\n        my $x1 = 3*$k - (($q - $p) >> 1);\n        my $x2 = 3*$k + (($q - $p) >> 1);\n\n        if (($x1 - 2*$k) > 0) {\n            push @solutions, [$x1, $k];\n        }\n\n        if ($x1 != $x2) {\n            push @solutions, [$x2, $k];\n        }\n    }\n\n    return sort { $a->[0] <=> $b->[0] } @solutions;\n}\n\nmy $n         = 900;\nmy @solutions = difference_of_three_squares_solutions($n);\n\nforeach my $solution (@solutions) {\n\n    my $x = $solution->[0];\n    my $k = $solution->[1];\n\n    say \"[$x, $k] => $x^2 - ($x - $k)^2 - ($x - 2*$k)^2 = $n\";\n}\n\n__END__\n[35, 17] => 35^2 - (35 - 17)^2 - (35 - 2*17)^2 = 900\n[45, 15] => 45^2 - (45 - 15)^2 - (45 - 2*15)^2 = 900\n[67, 17] => 67^2 - (67 - 17)^2 - (67 - 2*17)^2 = 900\n[115, 25] => 115^2 - (115 - 25)^2 - (115 - 2*25)^2 = 900\n[189, 39] => 189^2 - (189 - 39)^2 - (189 - 2*39)^2 = 900\n[563, 113] => 563^2 - (563 - 113)^2 - (563 - 2*113)^2 = 900\n"
  },
  {
    "path": "Math/difference_of_two_squares_solutions.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 09 August 2017\n# Edit: 26 October 2017\n# https://github.com/trizen\n\n# A simple and efficient algorithm for finding all the non-negative integer solutions to the equation:\n#\n#   x^2 - y^2 = n\n#\n# where `n` is known (along with its prime factorization).\n\n# Blog post:\n#   https://trizenx.blogspot.com/2017/10/representing-integers-as-difference-of.html\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(divisors);\n\nsub difference_of_two_squares_solutions {\n    my ($n) = @_;\n\n    my @solutions;\n    foreach my $divisor (divisors($n)) {\n\n        last if $divisor > sqrt($n);\n\n        my $p = $divisor;\n        my $q = $n / $divisor;\n\n        ($p + $q) % 2 == 0 or next;\n\n        my $x = ($q + $p) >> 1;\n        my $y = ($q - $p) >> 1;\n\n        unshift @solutions, [$x, $y];\n    }\n\n    return @solutions;\n}\n\nforeach my $n (1 .. 1e2) {\n    (my @solutions = difference_of_two_squares_solutions($n)) || next;\n\n    say \"$n = \", join(' = ', map { \"$_->[0]^2 - $_->[1]^2\" } @solutions);\n\n    # Verify solutions\n    foreach my $solution(@solutions) {\n        if ($solution->[0]**2 - $solution->[1]**2 != $n) {\n            die \"Error for $n: (@$solution)\";\n        }\n    }\n}\n\n__END__\n99937 = 721^2 - 648^2 = 1369^2 - 1332^2 = 49969^2 - 49968^2\n99939 = 2390^2 - 2369^2 = 7142^2 - 7135^2 = 16658^2 - 16655^2 = 49970^2 - 49969^2\n99940 = 358^2 - 168^2 = 1334^2 - 1296^2 = 5002^2 - 4992^2 = 24986^2 - 24984^2\n99941 = 429^2 - 290^2 = 49971^2 - 49970^2\n99943 = 2948^2 - 2931^2 = 49972^2 - 49971^2\n99944 = 465^2 - 341^2 = 837^2 - 775^2 = 987^2 - 935^2 = 1935^2 - 1909^2 = 12495^2 - 12491^2 = 24987^2 - 24985^2\n99945 = 1133^2 - 1088^2 = 3339^2 - 3324^2 = 5557^2 - 5548^2 = 9997^2 - 9992^2 = 16659^2 - 16656^2 = 49973^2 - 49972^2\n99947 = 606^2 - 517^2 = 49974^2 - 49973^2\n99948 = 8332^2 - 8326^2 = 24988^2 - 24986^2\n99949 = 457^2 - 330^2 = 49975^2 - 49974^2\n99951 = 16660^2 - 16657^2 = 49976^2 - 49975^2\n99952 = 6251^2 - 6243^2 = 12496^2 - 12492^2 = 24989^2 - 24987^2\n99953 = 447^2 - 316^2 = 513^2 - 404^2 = 7143^2 - 7136^2 = 49977^2 - 49976^2\n99955 = 9998^2 - 9993^2 = 49978^2 - 49977^2\n99956 = 24990^2 - 24988^2\n99957 = 331^2 - 98^2 = 421^2 - 278^2 = 1301^2 - 1262^2 = 1531^2 - 1498^2 = 3851^2 - 3838^2 = 4549^2 - 4538^2 = 16661^2 - 16658^2 = 49979^2 - 49978^2\n99959 = 2640^2 - 2621^2 = 49980^2 - 49979^2\n99960 = 317^2 - 23^2 = 329^2 - 91^2 = 343^2 - 133^2 = 347^2 - 143^2 = 353^2 - 157^2 = 379^2 - 209^2 = 427^2 - 287^2 = 541^2 - 439^2 = 559^2 - 461^2 = 637^2 - 553^2 = 749^2 - 679^2 = 769^2 - 701^2 = 863^2 - 803^2 = 1211^2 - 1169^2 = 1487^2 - 1453^2 = 1681^2 - 1651^2 = 1799^2 - 1771^2 = 2509^2 - 2489^2 = 3577^2 - 3563^2 = 4171^2 - 4159^2 = 5003^2 - 4993^2 = 8333^2 - 8327^2 = 12497^2 - 12493^2 = 24991^2 - 24989^2\n99961 = 49981^2 - 49980^2\n99963 = 322^2 - 61^2 = 618^2 - 531^2 = 1738^2 - 1709^2 = 5558^2 - 5549^2 = 16662^2 - 16659^2 = 49982^2 - 49981^2\n99964 = 440^2 - 306^2 = 24992^2 - 24990^2\n99965 = 9999^2 - 9994^2 = 49983^2 - 49982^2\n99967 = 7144^2 - 7137^2 = 49984^2 - 49983^2\n99968 = 318^2 - 34^2 = 372^2 - 196^2 = 423^2 - 281^2 = 612^2 - 524^2 = 813^2 - 749^2 = 1158^2 - 1114^2 = 1578^2 - 1546^2 = 2283^2 - 2261^2 = 3132^2 - 3116^2 = 6252^2 - 6244^2 = 12498^2 - 12494^2 = 24993^2 - 24991^2\n99969 = 425^2 - 284^2 = 1087^2 - 1040^2 = 16663^2 - 16660^2 = 49985^2 - 49984^2\n99971 = 49986^2 - 49985^2\n99972 = 2786^2 - 2768^2 = 8334^2 - 8328^2 = 24994^2 - 24992^2\n99973 = 323^2 - 66^2 = 49987^2 - 49986^2\n99975 = 340^2 - 125^2 = 400^2 - 245^2 = 452^2 - 323^2 = 584^2 - 491^2 = 704^2 - 629^2 = 1184^2 - 1141^2 = 1628^2 - 1597^2 = 2012^2 - 1987^2 = 3340^2 - 3325^2 = 10000^2 - 9995^2 = 16664^2 - 16661^2 = 49988^2 - 49987^2\n99976 = 12499^2 - 12495^2 = 24995^2 - 24993^2\n99977 = 2949^2 - 2932^2 = 49989^2 - 49988^2\n99979 = 410^2 - 261^2 = 850^2 - 789^2 = 4550^2 - 4539^2 = 49990^2 - 49989^2\n99980 = 5004^2 - 4994^2 = 24996^2 - 24994^2\n99981 = 345^2 - 138^2 = 359^2 - 170^2 = 391^2 - 230^2 = 759^2 - 690^2 = 825^2 - 762^2 = 1865^2 - 1838^2 = 2185^2 - 2162^2 = 2391^2 - 2370^2 = 5559^2 - 5550^2 = 7145^2 - 7138^2 = 16665^2 - 16662^2 = 49991^2 - 49990^2\n99983 = 3852^2 - 3839^2 = 49992^2 - 49991^2\n99984 = 2095^2 - 2071^2 = 4172^2 - 4160^2 = 6253^2 - 6245^2 = 8335^2 - 8329^2 = 12500^2 - 12496^2 = 24997^2 - 24995^2\n99985 = 10001^2 - 9996^2 = 49993^2 - 49992^2\n99987 = 16666^2 - 16663^2 = 49994^2 - 49993^2\n99988 = 3578^2 - 3564^2 = 24998^2 - 24996^2\n99989 = 49995^2 - 49994^2\n99991 = 49996^2 - 49995^2\n99992 = 489^2 - 373^2 = 891^2 - 833^2 = 12501^2 - 12497^2 = 24999^2 - 24997^2\n99993 = 16667^2 - 16664^2 = 49997^2 - 49996^2\n99995 = 1446^2 - 1411^2 = 7146^2 - 7139^2 = 10002^2 - 9997^2 = 49998^2 - 49997^2\n99996 = 680^2 - 602^2 = 1936^2 - 1910^2 = 8336^2 - 8330^2 = 25000^2 - 24998^2\n99997 = 319^2 - 42^2 = 2641^2 - 2622^2 = 49999^2 - 49998^2\n99999 = 320^2 - 49^2 = 468^2 - 345^2 = 1240^2 - 1199^2 = 5560^2 - 5551^2 = 16668^2 - 16665^2 = 50000^2 - 49999^2\n100000 = 325^2 - 75^2 = 350^2 - 150^2 = 550^2 - 450^2 = 665^2 - 585^2 = 1025^2 - 975^2 = 1270^2 - 1230^2 = 2510^2 - 2490^2 = 3133^2 - 3117^2 = 5005^2 - 4995^2 = 6254^2 - 6246^2 = 12502^2 - 12498^2 = 25001^2 - 24999^2\n"
  },
  {
    "path": "Math/digits_to_number_subquadratic_algorithm.pl",
    "content": "#!/usr/bin/perl\n\n# Subquadratic algorithm for converting a given list of digits in a given base, to an integer.\n\n# Algorithm presented in the book:\n#\n#   Modern Computer Arithmetic\n#           - by Richard P. Brent and Paul Zimmermann\n#\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub FastIntegerInput ($digits, $B) {\n\n    my @l = reverse @$digits;\n    my ($b, $k) = ($B, scalar(@l));\n\n    while ($k > 1) {\n        my @T;\n        for (1 ... (@l >> 1)) {\n            push(@T, addint(shift(@l), mulint($b, shift(@l))));\n        }\n        push(@T, shift(@l)) if @l;\n        @l = @T;\n        $b = mulint($b, $b);\n        $k = ($k >> 1) + ($k % 2);\n    }\n\n    $l[0];\n}\n\nforeach my $B (2 .. 100) {    # run some tests\n    my $N = factorial($B);    # int(rand(~0));\n\n    my @a = todigits($N, $B);\n    my $K = FastIntegerInput(\\@a, $B);\n\n    if ($N != $K) {\n        die \"Error for N = $N -> got $K\";\n    }\n}\n\nsay join ', ', FastIntegerInput([todigits(5040, 10)], 10);    #=> 5040\nsay join ', ', FastIntegerInput([todigits(5040, 11)], 11);    #=> 5040\nsay join ', ', FastIntegerInput([todigits(5040, 12)], 12);    #=> 5040\nsay join ', ', FastIntegerInput([todigits(5040, 13)], 13);    #=> 5040\n"
  },
  {
    "path": "Math/digits_to_number_subquadratic_algorithm_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Subquadratic algorithm for converting a given list of digits in a given base, to an integer.\n\n# Algorithm presented in the book:\n#\n#   Modern Computer Arithmetic\n#           - by Richard P. Brent and Paul Zimmermann\n#\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory qw(:all);\n\nsub FastIntegerInput ($digits, $base = 10) {\n\n    my $L = [map { Math::GMPz->new(\"$_\") } reverse @$digits];\n    my $B = Math::GMPz->new(\"$base\");\n\n    # Subquadratic Algorithm 1.25 FastIntegerInput from \"Modern Computer Arithmetic v0.5.9\"\n    for (my $k = scalar(@$L) ; $k > 1 ; $k = ($k >> 1) + ($k & 1)) {\n\n        my @T;\n        for (0 .. ($k >> 1) - 1) {\n            my $t = Math::GMPz::Rmpz_init_set($L->[2 * $_]);\n            Math::GMPz::Rmpz_addmul($t, $L->[2 * $_ + 1], $B);\n            push(@T, $t);\n        }\n\n        push(@T, $L->[-1]) if ($k & 1);\n        $L = \\@T;\n        Math::GMPz::Rmpz_mul($B, $B, $B);\n    }\n\n    return $L->[0];\n}\n\nforeach my $B (2 .. 100) {    # run some tests\n    my $N = factorial($B);    # int(rand(~0));\n\n    my @a = todigits($N, $B);\n    my $K = FastIntegerInput(\\@a, $B);\n\n    if ($N != $K) {\n        die \"Error for N = $N -> got $K\";\n    }\n}\n\nsay join ', ', FastIntegerInput([todigits(5040, 10)], 10);    #=> 5040\nsay join ', ', FastIntegerInput([todigits(5040, 11)], 11);    #=> 5040\nsay join ', ', FastIntegerInput([todigits(5040, 12)], 12);    #=> 5040\nsay join ', ', FastIntegerInput([todigits(5040, 13)], 13);    #=> 5040\n"
  },
  {
    "path": "Math/dirichlet_hyperbola_method.pl",
    "content": "#!/usr/bin/perl\n\n# Simple implementation of Dirichlet's hyperbola method.\n\n# Useful to compute partial sums of in sublinear time:\n#   Sum_{d|n} g(d) * h(n/d)\n\n# See also:\n#   https://en.wikipedia.org/wiki/Dirichlet_hyperbola_method\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse Math::AnyNum qw(faulhaber_sum);\nuse experimental qw(signatures);\n\nsub dirichlet_hyperbola_method ($n, $g, $h, $G, $H) {\n\n    my $s = sqrtint($n);\n\n    my $A = 0;\n    my $B = 0;\n    my $C = 0;\n\n    foreach my $k (1 .. $s) {\n\n        my $gk = $g->($k);\n        my $hk = $h->($k);\n\n        $A += $gk * $H->(divint($n, $k));\n        $A += $hk * $G->(divint($n, $k));\n\n        $B += $gk;\n        $C += $hk;\n    }\n\n    $A - $B * $C;\n}\n\nsub g ($n) { $n }\nsub h ($n) { moebius($n) }\n\nsub G ($n) { faulhaber_sum($n, 1) }    # partial sums of g(n): Sum_{k=1..n} g(k)\nsub H ($n) { mertens($n) }             # partial sums of h(n): Sum_{k=1..n} h(k)\n\nforeach my $n (1 .. 8) {\n    say \"S(10^$n) = \", dirichlet_hyperbola_method(powint(10, $n), \\&g, \\&h, \\&G, \\&H);\n}\n\n__END__\nS(10^1) = 32\nS(10^2) = 3044\nS(10^3) = 304192\nS(10^4) = 30397486\nS(10^5) = 3039650754\nS(10^6) = 303963552392\nS(10^7) = 30396356427242\nS(10^8) = 3039635516365908\n"
  },
  {
    "path": "Math/discrete_logarithm_pollard_rho.pl",
    "content": "#!/usr/bin/perl\n\n# Pohlig-Hellman with Pollard's rho for each prime-power factor.\n\n# Pollard's rho algorithm for logarithms\n# https://en.wikipedia.org/wiki/Pollard%27s_rho_algorithm_for_logarithms\n\nuse 5.036;\nuse ntheory qw(:all);\n\n# Pollard's rho for discrete logarithm in a group of prime order\nsub _pollard_rho_log($g, $h, $p, $n, $max_tries = 10) {\n\n    # Trivial cases\n    return 0 if ($h == 1);\n    return 1 if ($g == $h);\n\n    # For very small prime orders, brute force is simpler and reliable\n    if ($p <= 100) {\n        my $t = 1;\n        for my $i (0 .. $p - 1) {\n            return $i if $t == $h;\n            $t = mulmod($t, $g, $n);\n        }\n        return undef;\n    }\n\n    foreach my $attempt (1 .. $max_tries) {\n\n        # Random starting point (a,b) with X = g^a * h^b\n        my $a1 = urandomm($p);\n        my $b1 = urandomm($p);\n        my $x1 = mulmod(powmod($g, $a1, $n), powmod($h, $b1, $n), $n);\n\n        my $a2 = $a1;\n        my $b2 = $b1;\n        my $x2 = $x1;\n\n        # Floyd's cycle detection\n        my $iter = sub($a, $b, $x) {\n            my $r = ($x % 3);\n            if ($r == 0) {\n                $a = addmod($a, 1, $p);\n                $x = mulmod($x, $g, $n);\n            }\n            elsif ($r == 1) {\n                $b = addmod($b, 1, $p);\n                $x = mulmod($x, $h, $n);\n            }\n            else {\n                $a = mulmod(2,  $a, $p);\n                $b = mulmod(2,  $b, $p);\n                $x = mulmod($x, $x, $n);\n            }\n            return ($a, $b, $x);\n        };\n\n        while (1) {\n\n            # Tortoise step\n            ($a1, $b1, $x1) = $iter->($a1, $b1, $x1);\n\n            # Hare step (two iterations)\n            ($a2, $b2, $x2) = $iter->($a2, $b2, $x2);\n            ($a2, $b2, $x2) = $iter->($a2, $b2, $x2);\n\n            if ($x1 == $x2) {\n\n                # Collision: g^{a1} h^{b1} = g^{a2} h^{b2}\n                my $da = submod($a1, $a2, $p);\n                my $db = submod($b2, $b1, $p);\n\n                if ($db == 0) {\n                    last;    # degenerate case, restart\n                }\n\n                my $x = mulmod($da, invmod($db, $p), $p);\n\n                if (powmod($g, $x, $n) == $h) {\n                    return $x;\n                }\n                last;    # verification failed, restart\n            }\n        }\n    }\n\n    return undef;    # failed after max_tries\n}\n\n# Solve g^x = a (mod n) where g has order exactly p^e * r,\n# and we want x modulo p^e.\nsub _prime_power_log($a, $g, $n, $p, $e, $full_order) {\n\n    my $L = $full_order;\n    my $r = divint($L, powint($p, $e));    # co-factor\n\n    # Move into the subgroup of order p^e\n    my $g0 = powmod($g, $r, $n);\n    my $a0 = powmod($a, $r, $n);\n\n    my $x     = 0;\n    my $cur_g = $g0;                       # current generator, order p^{e-i}\n    my $cur_a = $a0;                       # current element\n    my $f     = 1;                         # current digit multiplier\n\n    my $sub_g = powmod($g0, powint($p, $e - 1), $n);    # generator of order p\n\n    foreach my $i (0 .. $e - 1) {\n\n        # Create an element of order p by raising to p^{e-1-i}\n        my $exp   = powint($p, $e - $i - 1);\n        my $sub_a = powmod($cur_a, $exp, $n);           # corresponding element\n\n        # Solve the discrete log in the prime-order subgroup\n        my $d = _pollard_rho_log($sub_g, $sub_a, $p, $n) // return undef;\n\n        $x = addint($x, mulint($d, $f));\n        $f = mulint($f, $p);\n\n        # Remove the already found part\n        $cur_a = mulmod($cur_a, powmod($cur_g, -$d, $n), $n);\n        $cur_g = powmod($cur_g, $p, $n);                        # next generator, order p^{e-1-i}\n    }\n\n    return $x;\n}\n\n# Solve g^x = a (mod n) where gcd(g, n) = 1, using Pohlig-Hellman over order of g.\n# Suitable when n is a prime power (or when called per prime-power factor of n).\nsub _dlog_coprime_prime_power_mod($a, $g, $n) {\n\n    my $order = znorder($g, $n) // return undef;\n\n    # Quick necessary condition: a must lie in the subgroup generated by g\n    if (powmod($a, $order, $n) != 1) {\n        return undef;\n    }\n\n    # Trivial case\n    if ($order == 1) {\n        return ($a == 1 ? 0 : undef);\n    }\n\n    # Factor the order into prime powers and solve for each\n    my @factors  = factor_exp($order);\n    my @residues = ();\n\n    foreach my $pp (@factors) {\n        my ($p, $e) = @$pp;\n        my $x = _prime_power_log($a, $g, $n, $p, $e, $order) // return undef;\n        push @residues, [$x, powint($p, $e)];\n    }\n\n    # Combine via CRT\n    my $x = chinese(@residues);\n\n    # Verify\n    (defined($x) && powmod($g, $x, $n) == $a) ? $x : undef;\n}\n\nsub discrete_log($a, $g, $n) {\n\n    # Normalise inputs\n    $a = modint($a, $n);\n    $g = modint($g, $n);\n\n    # Handle non-coprime case: gcd(g, n) > 1\n    if (gcd($g, $n) != 1) {\n\n        my $g_pow = 1;     # g^k mod n (original n), for direct equality check\n        my $n_red = $n;    # modulus being reduced\n        my $a_red = $a;    # target being reduced\n        my $d_acc = 1;     # accumulated product: (g/D_1)*(g/D_2)*...*(g/D_k) mod n_red\n        my $k     = 0;\n\n        while (gcd($g, $n_red) != 1) {\n\n            # Check if g^k already equals a (mod n)\n            return $k if $g_pow == $a;\n\n            my $D = gcd($g, $n_red);\n            return undef if $a_red % $D != 0;\n\n            $n_red = divint($n_red, $D);\n            $a_red = divint($a_red, $D);\n            $d_acc = mulmod($d_acc, divint($g, $D), $n_red);\n            $k++;\n            $g_pow = mulmod($g_pow, $g, $n);\n        }\n\n        # Final direct check after stripping\n        return $k if $g_pow == $a;\n\n        # Phase 2: gcd(g, n_red) = 1 now; solve g^y = a_red * inv(d_acc) (mod n_red)\n        my $inv_d = invmod($d_acc, $n_red) // return undef;\n        my $a_new = mulmod($a_red, $inv_d, $n_red);\n        my $y     = discrete_log($a_new, $g, $n_red);\n        return defined($y) ? $k + $y : undef;\n    }\n\n    # Coprime case: gcd(g, n) = 1\n\n    # Factor n into prime powers\n    my @n_factors = factor_exp($n);\n\n    # Composite n: solve g^x = a (mod p^e) for each prime-power factor, then CRT\n    my @residues = ();\n\n    foreach my $pp (@n_factors) {\n        my ($p, $e) = @$pp;\n        my $pe  = powint($p, $e);\n        my $g_i = modint($g, $pe);\n        my $a_i = modint($a, $pe);\n\n        my $r = _dlog_coprime_prime_power_mod($a_i, $g_i, $pe);\n        return undef unless defined $r;\n\n        my $ord_i = znorder($g_i, $pe) // return undef;\n        push @residues, [$r, $ord_i];\n    }\n\n    # Combine via CRT\n    my $x = chinese(@residues) // return undef;\n\n    # Verify the result\n    (powmod($g, $x, $n) == $a) ? $x : undef;\n}\n\nuse Test::More tests => 1309;\n\nis(discrete_log(5678, 5, 10007), 8620);\n\nforeach my $test (\n                  [[5675,              5,      10000019],          2003974],            # 5675 = 5^2003974 mod 10000019\n                  [[18478760,          5,      314138927],         34034873],\n                  [[553521,            459996, 557057],            15471],\n                  [[7443282,           4,      13524947],          6762454],\n                  [[32712908945642193, 5,      71245073933756341], 5945146967010377],\n  ) {\n    my ($t, $v) = @$test;\n    say \"Testing: discrete_log(\", join(', ', @$t), \") = \", $v;\n    is(discrete_log($t->[0], $t->[1], $t->[2]), $v);\n}\n\nis_deeply(\n          [map { discrete_log(powint(2, $_) - 5, 3, powint(2, $_ + 1)) } 0 .. 35],\n          [undef,  0,       undef,    1,        7,        3,         27,       43,        75,        139,        11,         779,\n           267,    1291,    3339,     7435,     32011,    48395,     81163,    146699,    277771,    15627,      1588491,    2637067,\n           539915, 4734219, 13122827, 63454475, 29900043, 231226635, 97008907, 902315275, 365444363, 1439186187, 3586669835, 7881637131\n          ]\n         );\n\nis_deeply([map { discrete_log(-1, 3, powint(3, $_) - 2) // 0 } 2 .. 30],\n          [3, 10, 39, 60, 121, 0, 117, 4920, 0, 0, 0, 28322, 0, 1434890, 0, 0, 0, 116226146, 0, 0, 15690529803, 0, 108443565, 66891206007, 0, 0, 0, 0, 0]);\n\n# Non-coprime tests\nis(discrete_log(36, 44, 50), 2);    # 44^2 = 1936 = 36 (mod 50), gcd(44,50)=2\nis(discrete_log(0,  2,  4),  2);    # 2^2 = 4 = 0 (mod 4)\nis(discrete_log(4,  6,  8),  2);    # 6^2 = 36 = 4 (mod 8)\n\n# Composite modulus, coprime base\nis(discrete_log(130, 85, 177), 15);    # 177 = 3*59, gcd(85,177)=1\nis(discrete_log(100, 52, 209), 10);    # 209 = 11*19, 52^10 = 100 (mod 209)\n\n# Verify no-solution cases still return undef\nis(discrete_log(3, 4, 6), undef);      # no solution exists\n\nis(discrete_log(1, 2, 7), 0);\nis(discrete_log(2, 2, 7), 1);\nis(discrete_log(4, 2, 7), 2);\nis(discrete_log(1, 3, 7), 0);\n\nis(discrete_log(3, 2, 5), 3);          # 2^3 mod 5 = 3\nis(discrete_log(4, 2, 5), 2);\n\nis(discrete_log(2,     4,     7),      2);\nis(discrete_log(4,     5,     7),      2);\nis(discrete_log(5,     3,     7),      5);\nis(discrete_log(130,   85,    177),    15);\nis(discrete_log(79,    92,    129),    2);\nis(discrete_log(115,   116,   141),    26);\nis(discrete_log(67741, 90737, 120309), 146);\nis(discrete_log(12,    42,    122),    13);\nis(discrete_log(36,    44,    50),     2);\nis(discrete_log(34,    170,   187),    5);\n\n# Small modulus cycles\n\nis(discrete_log(8, 2, 11), 3);\nis(discrete_log(5, 2, 11), 4);\nis(discrete_log(9, 3, 11), 2);\n\n# Edge cases\n\nis(discrete_log(1, 1, 13), 0);\nis(discrete_log(1, 5, 13), 0);\n\n# g == a\nis(discrete_log(7, 7, 19), 1);\n\n# modulus 2\nis(discrete_log(1, 1, 2), 0);\n\n# Non-prime modulus\n\nis(discrete_log(4, 2, 15), 2);    # 2^2 = 4 mod 15\nis(discrete_log(1, 4, 9),  0);\n\n# Cases where solution may not exist\n\nis(discrete_log(3, 4, 7), undef);\nis(discrete_log(3, 2, 4), undef);\nis(discrete_log(6, 4, 8), undef);\n\n# Verify correctness by recomputing power\n\nfor my $n (7, 11, 13, 17) {\n    for my $g (2 .. $n - 1) {\n        for my $k (0 .. $n - 1) {\n\n            my $a = powmod($g, $k, $n);\n            my $r = discrete_log($a, $g, $n);\n\n            ok(defined($r), \"discrete_log($a, $g, $n)\");\n            is(powmod($g, $r, $n), $a) if defined($r);\n        }\n    }\n}\n\n# Randomized tests\n\nfor (1 .. 100) {\n    my $n = urandomm(200000 - 50000) + 50000;\n    my $g = urandomm($n - 2) + 2;\n    my $k = urandomm(50000);\n\n    my $a = powmod($g, $k, $n);\n    my $r = discrete_log($a, $g, $n);\n\n    ok(defined($r), \"discrete_log($a, $g, $n)\");\n    is(powmod($g, $r, $n), $a) if defined($r);\n}\n\n# Computationally intensive tests\n\nmy $p = 1000003;\nmy $g = 2;\nmy $k = 123456;\n\nmy $a = powmod($g, $k, $p);\n\nis(powmod($g, discrete_log($a, $g, $p), $p), $a);\n\n# Larger exponent\n\nmy $k2 = 654321;\nmy $a2 = powmod($g, $k2, $p);\n\nis(powmod($g, discrete_log($a2, $g, $p), $p), $a2);\n\n# Large prime modulus stress test\n\nmy $p2 = 10000019;\nmy $g2 = 2;\nmy $k3 = 777777;\n\nmy $a3 = powmod($g2, $k3, $p2);\n\nis(powmod($g2, discrete_log($a3, $g2, $p2), $p2), $a3);\n"
  },
  {
    "path": "Math/discrete_logarithm_pollard_rho_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Pohlig-Hellman with Pollard's rho for each prime-power factor.\n\n# Pollard's rho algorithm for logarithms\n# https://en.wikipedia.org/wiki/Pollard%27s_rho_algorithm_for_logarithms\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory qw(:all);\n\n# Pollard's rho for discrete logarithm in a group of prime order\nsub _znlog_pollard_rho ($g, $h, $p, $n, $max_tries = 10) {\n\n    if (Math::GMPz::Rmpz_cmp_ui($h, 1) == 0) {\n        return Math::GMPz::Rmpz_init_set_ui(0);\n    }\n    if (Math::GMPz::Rmpz_cmp($g, $h) == 0) {\n        return Math::GMPz::Rmpz_init_set_ui(1);\n    }\n\n    # For very small prime orders, brute force is simpler and reliable\n    if (Math::GMPz::Rmpz_cmp_ui($p, 100) <= 0) {\n        my $t = Math::GMPz::Rmpz_init_set_ui(1);\n        for my $i (0 .. Math::GMPz::Rmpz_get_ui($p) - 1) {\n            if (Math::GMPz::Rmpz_cmp($t, $h) == 0) {\n                return Math::GMPz::Rmpz_init_set_ui($i);\n            }\n            Math::GMPz::Rmpz_mul($t, $t, $g);\n            Math::GMPz::Rmpz_mod($t, $t, $n);\n        }\n        return undef;\n    }\n\n    state $rng = Math::GMPz::zgmp_randinit_default_nobless();\n\n    state $tmp   = Math::GMPz::Rmpz_init_nobless();\n    state $a1    = Math::GMPz::Rmpz_init_nobless();\n    state $b1    = Math::GMPz::Rmpz_init_nobless();\n    state $x1    = Math::GMPz::Rmpz_init_nobless();\n    state $a2    = Math::GMPz::Rmpz_init_nobless();\n    state $b2    = Math::GMPz::Rmpz_init_nobless();\n    state $x2    = Math::GMPz::Rmpz_init_nobless();\n    state $da    = Math::GMPz::Rmpz_init_nobless();\n    state $db    = Math::GMPz::Rmpz_init_nobless();\n    state $invdb = Math::GMPz::Rmpz_init_nobless();\n\n    foreach my $attempt (1 .. $max_tries) {\n\n        # Random starting point (a,b) with X = g^a * h^b\n        Math::GMPz::Rmpz_urandomm($a1, $b1, $rng, $p, 2);\n\n        Math::GMPz::Rmpz_powm($x1,  $g, $a1, $n);\n        Math::GMPz::Rmpz_powm($tmp, $h, $b1, $n);\n        Math::GMPz::Rmpz_mul($x1, $x1, $tmp);\n        Math::GMPz::Rmpz_mod($x1, $x1, $n);\n\n        Math::GMPz::Rmpz_set($a2, $a1);\n        Math::GMPz::Rmpz_set($b2, $b1);\n        Math::GMPz::Rmpz_set($x2, $x1);\n\n        while (1) {\n\n            # Tortoise step (Inlined)\n            my $r1 = Math::GMPz::Rmpz_mod_ui($tmp, $x1, 3);\n            if ($r1 == 0) {\n                Math::GMPz::Rmpz_add_ui($a1, $a1, 1);\n                Math::GMPz::Rmpz_mul($x1, $x1, $g);\n                Math::GMPz::Rmpz_mod($x1, $x1, $n);\n            }\n            elsif ($r1 == 1) {\n                Math::GMPz::Rmpz_add_ui($b1, $b1, 1);\n                Math::GMPz::Rmpz_mul($x1, $x1, $h);\n                Math::GMPz::Rmpz_mod($x1, $x1, $n);\n            }\n            else {\n                Math::GMPz::Rmpz_mul_2exp($a1, $a1, 1);\n                Math::GMPz::Rmpz_mul_2exp($b1, $b1, 1);\n                Math::GMPz::Rmpz_mod($a1, $a1, $p);\n                Math::GMPz::Rmpz_mod($b1, $b1, $p);\n                Math::GMPz::Rmpz_powm_ui($x1, $x1, 2, $n);\n            }\n\n            # Hare step (Inlined, two iterations)\n            for (1 .. 2) {\n                my $r2 = Math::GMPz::Rmpz_mod_ui($tmp, $x2, 3);\n                if ($r2 == 0) {\n                    Math::GMPz::Rmpz_add_ui($a2, $a2, 1);\n                    Math::GMPz::Rmpz_mul($x2, $x2, $g);\n                    Math::GMPz::Rmpz_mod($x2, $x2, $n);\n                }\n                elsif ($r2 == 1) {\n                    Math::GMPz::Rmpz_add_ui($b2, $b2, 1);\n                    Math::GMPz::Rmpz_mul($x2, $x2, $h);\n                    Math::GMPz::Rmpz_mod($x2, $x2, $n);\n                }\n                else {\n                    Math::GMPz::Rmpz_mul_2exp($a2, $a2, 1);\n                    Math::GMPz::Rmpz_mul_2exp($b2, $b2, 1);\n                    Math::GMPz::Rmpz_mod($a2, $a2, $p);\n                    Math::GMPz::Rmpz_mod($b2, $b2, $p);\n                    Math::GMPz::Rmpz_powm_ui($x2, $x2, 2, $n);\n                }\n            }\n\n            if (Math::GMPz::Rmpz_cmp($x1, $x2) == 0) {\n\n                # Collision: g^{a1} h^{b1} = g^{a2} h^{b2}\n                Math::GMPz::Rmpz_sub($da, $a1, $a2);\n                Math::GMPz::Rmpz_mod($da, $da, $p);\n\n                Math::GMPz::Rmpz_sub($db, $b2, $b1);\n                Math::GMPz::Rmpz_mod($db, $db, $p);\n\n                last if Math::GMPz::Rmpz_sgn($db) == 0;    # Degenerate case, restart\n\n                Math::GMPz::Rmpz_invert($invdb, $db, $p) || last;\n\n                my $x = Math::GMPz::Rmpz_init();\n                Math::GMPz::Rmpz_mul($x, $da, $invdb);\n                Math::GMPz::Rmpz_mod($x, $x, $p);\n\n                Math::GMPz::Rmpz_powm($tmp, $g, $x, $n);\n                return $x if Math::GMPz::Rmpz_cmp($tmp, $h) == 0;\n\n                last;                                      # Verification failed, restart\n            }\n        }\n    }\n    return undef;    # failed after max_tries\n}\n\n# Solve g^x = a (mod n) where g has order exactly p^e * r,\n# and we want x modulo p^e.\nsub _znlog_prime_power ($a, $g, $n, $p, $e, $full_order) {\n\n    my $L = $full_order;\n    state $r = Math::GMPz::Rmpz_init_nobless();\n    Math::GMPz::Rmpz_pow_ui($r, $p, $e);\n    Math::GMPz::Rmpz_divexact($r, $L, $r);    # co-factor\n\n    # Move into the subgroup of order p^e\n    state $g0 = Math::GMPz::Rmpz_init_nobless();\n    state $a0 = Math::GMPz::Rmpz_init_nobless();\n    Math::GMPz::Rmpz_powm($g0, $g, $r, $n);\n    Math::GMPz::Rmpz_powm($a0, $a, $r, $n);\n\n    my $x = Math::GMPz::Rmpz_init_set_ui(0);\n\n    state $cur_g = Math::GMPz::Rmpz_init_nobless();    # current generator, order p^{e-i}\n    state $cur_a = Math::GMPz::Rmpz_init_nobless();    # current element\n    Math::GMPz::Rmpz_set($cur_g, $g0);\n    Math::GMPz::Rmpz_set($cur_a, $a0);\n\n    state $f = Math::GMPz::Rmpz_init_nobless();        # current digit multiplier\n    Math::GMPz::Rmpz_set_ui($f, 1);\n\n    state $tmp   = Math::GMPz::Rmpz_init_nobless();\n    state $sub_g = Math::GMPz::Rmpz_init();            # generator of order p\n    state $sub_a = Math::GMPz::Rmpz_init();\n\n    Math::GMPz::Rmpz_pow_ui($tmp, $p, $e - 1);\n    Math::GMPz::Rmpz_powm($sub_g, $g0, $tmp, $n);\n\n    foreach my $i (0 .. $e - 1) {\n\n        # Create an element of order p by raising to p^{e-1-i}\n        Math::GMPz::Rmpz_pow_ui($tmp, $p, $e - $i - 1);\n        Math::GMPz::Rmpz_powm($sub_a, $cur_a, $tmp, $n);    # corresponding element\n\n        # Solve the discrete log in the prime-order subgroup\n        my $d = _znlog_pollard_rho($sub_g, $sub_a, $p, $n) // return undef;\n\n        Math::GMPz::Rmpz_mul($tmp, $d, $f);\n        Math::GMPz::Rmpz_add($x, $x, $tmp);\n        Math::GMPz::Rmpz_mul($f, $f, $p);\n\n        # Remove the already found part\n        Math::GMPz::Rmpz_powm($tmp, $cur_g, $d, $n);\n        Math::GMPz::Rmpz_invert($tmp, $tmp, $n) || return undef;\n        Math::GMPz::Rmpz_mul($cur_a, $cur_a, $tmp);\n        Math::GMPz::Rmpz_mod($cur_a, $cur_a, $n);\n\n        Math::GMPz::Rmpz_powm($cur_g, $cur_g, $p, $n);    # next generator, order p^{e-1-i}\n    }\n    return $x;\n}\n\nsub _znlog_coprime_prime_power ($a, $g, $n) {\n    my $order = Math::GMPz->new((znorder($g, $n) // return undef));\n\n    state $tmp   = Math::GMPz::Rmpz_init_nobless();\n    state $p_mpz = Math::GMPz::Rmpz_init_nobless();\n\n    # Quick necessary condition: a must lie in the subgroup generated by g\n    Math::GMPz::Rmpz_powm($tmp, $a, $order, $n);\n    return undef if Math::GMPz::Rmpz_cmp_ui($tmp, 1) != 0;\n\n    # Trivial case\n    if (Math::GMPz::Rmpz_cmp_ui($order, 1) == 0) {\n        return (Math::GMPz::Rmpz_cmp_ui($a, 1) == 0) ? 0 : undef;\n    }\n\n    # Factor the order into prime powers and solve for each\n    my @factors  = factor_exp($order);\n    my @residues = ();\n\n    foreach my $pp (@factors) {\n        my ($p, $e) = @$pp;\n        Math::GMPz::Rmpz_set_str($p_mpz, $p, 10);\n        my $x = _znlog_prime_power($a, $g, $n, $p_mpz, $e, $order) // return undef;\n        push @residues, [$x, powint($p, $e)];\n    }\n\n    # Combine via CRT\n    my $x = chinese(@residues) // return undef;\n\n    # Verify\n    Math::GMPz::Rmpz_set_str($tmp, $x, 10);\n    Math::GMPz::Rmpz_powm($tmp, $g, $tmp, $n);\n    return (Math::GMPz::Rmpz_cmp($tmp, $a) == 0) ? $x : undef;\n}\n\nsub _znlog_pohlig_hellman ($a, $g, $n) {\n\n    my $tmp = Math::GMPz::Rmpz_init_nobless();\n\n    Math::GMPz::Rmpz_gcd($tmp, $g, $n);\n\n    # Handle non-coprime case: gcd(g, n) != 1\n    if (Math::GMPz::Rmpz_cmp_ui($tmp, 1) != 0) {\n        my $g_pow = Math::GMPz::Rmpz_init_set_ui(1);    # g^k mod n (original n), for direct equality check\n        my $n_red = Math::GMPz::Rmpz_init_set($n);      # modulus being reduced\n        my $a_red = Math::GMPz::Rmpz_init_set($a);      # target being reduced\n        my $d_acc = Math::GMPz::Rmpz_init_set_ui(1);    # accumulated product: (g/D_1)*(g/D_2)*...*(g/D_k) mod n_red\n\n        my $k = 0;\n        while (1) {\n\n            # Check if g^k already equals a (mod n)\n            Math::GMPz::Rmpz_gcd($tmp, $g, $n_red);\n            last if Math::GMPz::Rmpz_cmp_ui($tmp, 1) == 0;\n\n            return $k if Math::GMPz::Rmpz_cmp($g_pow, $a) == 0;\n            return undef unless Math::GMPz::Rmpz_divisible_p($a_red, $tmp);\n\n            Math::GMPz::Rmpz_div($n_red, $n_red, $tmp);\n            Math::GMPz::Rmpz_div($a_red, $a_red, $tmp);\n\n            Math::GMPz::Rmpz_div($tmp, $g, $tmp);\n            Math::GMPz::Rmpz_mul($d_acc, $d_acc, $tmp);\n            Math::GMPz::Rmpz_mul($g_pow, $g_pow, $g);\n            Math::GMPz::Rmpz_mod($d_acc, $d_acc, $n_red);\n            Math::GMPz::Rmpz_mod($g_pow, $g_pow, $n);\n\n            ++$k;\n        }\n\n        # Final direct check after stripping\n        return $k if Math::GMPz::Rmpz_cmp($g_pow, $a) == 0;\n\n        # Phase 2: gcd(g, n_red) = 1 now; solve g^y = a_red * inv(d_acc) (mod n_red)\n        Math::GMPz::Rmpz_invert($tmp, $d_acc, $n_red) || return undef;\n        Math::GMPz::Rmpz_mul($tmp, $tmp, $a_red);\n\n        my $new_a = Math::GMPz::Rmpz_init();\n        my $new_g = Math::GMPz::Rmpz_init();\n\n        Math::GMPz::Rmpz_mod($new_a, $tmp, $n_red);\n        Math::GMPz::Rmpz_mod($new_g, $g,   $n_red);\n\n        my $y = __SUB__->($new_a, $new_g, $n_red) // return undef;\n        return ($y + $k);\n    }\n\n    # Coprime case: gcd(g, n) = 1\n\n    # Factor n into prime powers\n    my @n_factors = factor_exp($n);\n    my @residues  = ();\n\n    my $pe  = Math::GMPz::Rmpz_init();\n    my $g_i = Math::GMPz::Rmpz_init();\n    my $a_i = Math::GMPz::Rmpz_init();\n\n    # Composite n: solve g^x = a (mod p^e) for each prime-power factor, then CRT\n    foreach my $pp (@n_factors) {\n        my ($p, $e) = @$pp;\n\n        Math::GMPz::Rmpz_set_str($pe, $p, 10);\n        Math::GMPz::Rmpz_pow_ui($pe, $pe, $e);\n        Math::GMPz::Rmpz_mod($g_i, $g, $pe);\n        Math::GMPz::Rmpz_mod($a_i, $a, $pe);\n\n        my $r     = _znlog_coprime_prime_power($a_i, $g_i, $pe) // return undef;\n        my $ord_i = znorder($g_i, $pe)                          // return undef;\n\n        push @residues, [$r, $ord_i];\n    }\n\n    # Combine via CRT\n    my $x = Math::GMPz::Rmpz_init_set_str((chinese(@residues) // return undef), 10);\n\n    # Verify the result\n    Math::GMPz::Rmpz_powm($tmp, $g, $x, $n);\n    if (Math::GMPz::Rmpz_cmp($tmp, $a) == 0) {\n        return $x;\n    }\n\n    return undef;\n}\n\nsub discrete_log ($a, $g, $n) {\n\n    $a = Math::GMPz->new(\"$a\");\n    $g = Math::GMPz->new(\"$g\");\n    $n = Math::GMPz->new(\"$n\");\n\n    my $sgn = Math::GMPz::Rmpz_sgn($n) || return undef;\n\n    if ($sgn < 0) {\n        $n = Math::GMPz::Rmpz_init_set($n);\n        Math::GMPz::Rmpz_abs($n, $n);\n    }\n\n    return 0 if Math::GMPz::Rmpz_cmp_ui($n, 1) == 0;\n\n    $a = Math::GMPz::Rmpz_init_set($a);\n    $g = Math::GMPz::Rmpz_init_set($g);\n\n    Math::GMPz::Rmpz_mod($a, $a, $n);\n    Math::GMPz::Rmpz_mod($g, $g, $n);\n\n    if (Math::GMPz::Rmpz_cmp_ui($a, 1) == 0 or Math::GMPz::Rmpz_cmp_ui($g, 0) == 0) {\n        return 0;\n    }\n\n    my $res = _znlog_pohlig_hellman($a, $g, $n) // return undef;\n    return join '', $res;\n}\n\nuse Test::More tests => 1309;\n\nis(discrete_log(5678, 5, 10007), 8620);\n\nforeach my $test (\n                  [[5675,              5,      10000019],          2003974],            # 5675 = 5^2003974 mod 10000019\n                  [[18478760,          5,      314138927],         34034873],\n                  [[553521,            459996, 557057],            15471],\n                  [[7443282,           4,      13524947],          6762454],\n                  [[32712908945642193, 5,      71245073933756341], 5945146967010377],\n  ) {\n    my ($t, $v) = @$test;\n    say \"Testing: discrete_log(\", join(', ', @$t), \") = \", $v;\n    is(discrete_log($t->[0], $t->[1], $t->[2]), $v);\n}\n\nis_deeply(\n          [map { discrete_log(powint(2, $_) - 5, 3, powint(2, $_ + 1)) } 0 .. 35],\n          [undef,  0,       undef,    1,        7,        3,         27,       43,        75,        139,        11,         779,\n           267,    1291,    3339,     7435,     32011,    48395,     81163,    146699,    277771,    15627,      1588491,    2637067,\n           539915, 4734219, 13122827, 63454475, 29900043, 231226635, 97008907, 902315275, 365444363, 1439186187, 3586669835, 7881637131\n          ]\n         );\n\nis_deeply([map { discrete_log(-1, 3, powint(3, $_) - 2) // 0 } 2 .. 30],\n          [3, 10, 39, 60, 121, 0, 117, 4920, 0, 0, 0, 28322, 0, 1434890, 0, 0, 0, 116226146, 0, 0, 15690529803, 0, 108443565, 66891206007, 0, 0, 0, 0, 0]);\n\n# Non-coprime tests\nis(discrete_log(36, 44, 50), 2);    # 44^2 = 1936 = 36 (mod 50), gcd(44,50)=2\nis(discrete_log(0,  2,  4),  2);    # 2^2 = 4 = 0 (mod 4)\nis(discrete_log(4,  6,  8),  2);    # 6^2 = 36 = 4 (mod 8)\n\n# Composite modulus, coprime base\nis(discrete_log(130, 85, 177), 15);    # 177 = 3*59, gcd(85,177)=1\nis(discrete_log(100, 52, 209), 10);    # 209 = 11*19, 52^10 = 100 (mod 209)\n\n# Verify no-solution cases still return undef\nis(discrete_log(3, 4, 6), undef);      # no solution exists\n\nis(discrete_log(1, 2, 7), 0);\nis(discrete_log(2, 2, 7), 1);\nis(discrete_log(4, 2, 7), 2);\nis(discrete_log(1, 3, 7), 0);\n\nis(discrete_log(3, 2, 5), 3);          # 2^3 mod 5 = 3\nis(discrete_log(4, 2, 5), 2);\n\nis(discrete_log(2,     4,     7),      2);\nis(discrete_log(4,     5,     7),      2);\nis(discrete_log(5,     3,     7),      5);\nis(discrete_log(130,   85,    177),    15);\nis(discrete_log(79,    92,    129),    2);\nis(discrete_log(115,   116,   141),    26);\nis(discrete_log(67741, 90737, 120309), 146);\nis(discrete_log(12,    42,    122),    13);\nis(discrete_log(36,    44,    50),     2);\nis(discrete_log(34,    170,   187),    5);\n\n# Small modulus cycles\n\nis(discrete_log(8, 2, 11), 3);\nis(discrete_log(5, 2, 11), 4);\nis(discrete_log(9, 3, 11), 2);\n\n# Edge cases\n\nis(discrete_log(1, 1, 13), 0);\nis(discrete_log(1, 5, 13), 0);\n\n# g == a\nis(discrete_log(7, 7, 19), 1);\n\n# modulus 2\nis(discrete_log(1, 1, 2), 0);\n\n# Non-prime modulus\n\nis(discrete_log(4, 2, 15), 2);    # 2^2 = 4 mod 15\nis(discrete_log(1, 4, 9),  0);\n\n# Cases where solution may not exist\n\nis(discrete_log(3, 4, 7), undef);\nis(discrete_log(3, 2, 4), undef);\nis(discrete_log(6, 4, 8), undef);\n\n# Verify correctness by recomputing power\n\nfor my $n (7, 11, 13, 17) {\n    for my $g (2 .. $n - 1) {\n        for my $k (0 .. $n - 1) {\n\n            my $a = powmod($g, $k, $n);\n            my $r = discrete_log($a, $g, $n);\n\n            ok(defined($r), \"discrete_log($a, $g, $n)\");\n            is(powmod($g, $r, $n), $a) if defined($r);\n        }\n    }\n}\n\n# Randomized tests\n\nfor (1 .. 100) {\n    my $n = urandomm(200000 - 50000) + 50000;\n    my $g = urandomm($n - 2) + 2;\n    my $k = urandomm(50000);\n\n    my $a = powmod($g, $k, $n);\n    my $r = discrete_log($a, $g, $n);\n\n    ok(defined($r), \"discrete_log($a, $g, $n)\");\n    is(powmod($g, $r, $n), $a) if defined($r);\n}\n\n# Computationally intensive tests\n\nmy $p = 1000003;\nmy $g = 2;\nmy $k = 123456;\n\nmy $a = powmod($g, $k, $p);\n\nis(powmod($g, discrete_log($a, $g, $p), $p), $a);\n\n# Larger exponent\n\nmy $k2 = 654321;\nmy $a2 = powmod($g, $k2, $p);\n\nis(powmod($g, discrete_log($a2, $g, $p), $p), $a2);\n\n# Large prime modulus stress test\n\nmy $p2 = 10000019;\nmy $g2 = 2;\nmy $k3 = 777777;\n\nmy $a3 = powmod($g2, $k3, $p2);\n\nis(powmod($g2, discrete_log($a3, $g2, $p2), $p2), $a3);\n"
  },
  {
    "path": "Math/discrete_root.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 10 January 2017\n# https://github.com/trizen\n\n# An example for finding the smallest value `x` in:\n#\n#   x^e = r (mod n)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(invmod powmod euler_phi);\n\nsub discrete_root {\n    my ($e, $r, $n) = @_;\n    my $d = invmod($e, euler_phi($n));\n    powmod($r, $d, $n);\n}\n\n#\n## Solves for x in x^65537 = 1653 (mod 2279)\n#\n\nsay discrete_root(65537, 1653, 2279);        # 1234\n"
  },
  {
    "path": "Math/divisors_descending_lazy.pl",
    "content": "#!/usr/bin/perl\n\n# Lazily generate the positive divisors of a given integer `n`, in descending order.\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory 0.74 qw(:all);\n\nprime_set_config(bigint => 'Math::GMPz');\n\n# Binary search: returns first index i such that all arr[0..i-1] <= val\nsub bsearch_le ($arr, $val) {\n    my ($lo,  $hi)  = (0, scalar @$arr);\n    while ($lo < $hi) {\n        my $mid = ($lo + $hi) >> 1;\n        $arr->[$mid] <= $val ? ($lo = $mid + 1) : ($hi = $mid);\n    }\n    return $lo;\n}\n\n# Max-heap helper: Sifts down to maintain max-heap property\nsub sift_down ($heap, $pos) {\n    my $n = @$heap;\n    while (1) {\n        my $max = $pos;\n        my $c1  = 2 * $pos + 1;\n        my $c2  = $c1 + 1;\n        $max = $c1 if $c1 < $n && $heap->[$c1][0] > $heap->[$max][0];\n        $max = $c2 if $c2 < $n && $heap->[$c2][0] > $heap->[$max][0];\n        last if $max == $pos;\n        @{$heap}[$pos, $max] = @{$heap}[$max, $pos];\n        $pos = $max;\n    }\n}\n\nsub heap_push ($heap, $v) {\n    my $pos = @$heap;\n    push @$heap, $v;\n    while ($pos > 0) {\n        my $parent = ($pos - 1) >> 1;\n        last if $heap->[$parent][0] >= $heap->[$pos][0];\n        @{$heap}[$parent, $pos] = @{$heap}[$pos, $parent];\n        $pos = $parent;\n    }\n}\n\nsub heap_pop ($heap) {\n    return pop @$heap if @$heap <= 1;\n    my $top = $heap->[0];\n    $heap->[0] = pop @$heap;\n    sift_down($heap, 0);\n    return $top;\n}\n\nsub lazy_divisors ($n, $callback) {\n\n    # Build factor chains from the prime factorisation of f\n    my @chains;\n    for my $pe (factor_exp($n)) {\n        my ($p, $v) = @$pe;\n        my @C = map { powint($p, $_) } 0 .. $v;\n        push @chains, \\@C if @C;\n    }\n\n    @chains = sort { @$b <=> @$a } @chains;\n\n    # Distribute chains into two arrays\n    my @A = (Math::GMPz->new(1));\n    my @B = (Math::GMPz->new(1));\n\n    for my $C (@chains) {\n        my $ref = (@A < @B) ? \\@A : \\@B;\n        @$ref = map {\n            my $x = $_;\n            map { $x * $_ } @$C\n        } @$ref;\n    }\n\n    @A = sort { $a <=> $b } @A;\n    @B = sort { $a <=> $b } @B;\n\n    my $s = $n;    # maximum divisor\n                   #my $s = sqrtint($n);\n\n    # Seed the max-heap\n    my @h;\n    for my $i (0 .. $#A) {\n        my $lim = $s / $A[$i];              # Largest B[j] such that A[i] * B[j] <= n\n        my $j   = bsearch_le(\\@B, $lim);\n        next unless $j > 0;\n        push @h, [$A[$i] * $B[$j - 1], $i, $j - 1];\n    }\n\n    # Heapify using O(n) bottom-up approach\n    sift_down(\\@h, $_) for reverse(0 .. ((@h >> 1) - 1));\n\n    # Build all divisors as products of one divisor from @A and one from @B,\n    # then merge the row-wise sequences in descending order with a max-heap.\n    while (@h) {\n        my ($k, $i, $j) = @{heap_pop(\\@h)};\n\n        $callback->($k);\n\n        # Push the next divisor combination into the heap\n        if ($j > 0) {\n            heap_push(\\@h, [$A[$i] * $B[$j - 1], $i, $j - 1]);\n        }\n    }\n\n    return;\n}\n\nlazy_divisors(5040, sub($d) { say $d });\n"
  },
  {
    "path": "Math/divisors_lazy.pl",
    "content": "#!/usr/bin/perl\n\n# Lazily generate the positive divisors of a given integer `n`, in ascending order.\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory 0.74 qw(:all);\n\nprime_set_config(bigint => 'Math::GMPz');\n\nsub sift_down($heap, $pos) {\n\n    my $n = @$heap;\n    while (1) {\n\n        my $min = $pos;\n        my $c1  = 2 * $pos + 1;\n        my $c2  = $c1 + 1;\n\n        $min = $c1 if $c1 < $n && $heap->[$c1][0] < $heap->[$min][0];\n        $min = $c2 if $c2 < $n && $heap->[$c2][0] < $heap->[$min][0];\n\n        last if $min == $pos;\n        @{$heap}[$pos, $min] = @{$heap}[$min, $pos];\n        $pos = $min;\n    }\n}\n\nsub heap_push($heap, $v) {\n\n    my $pos = @$heap;\n    push @$heap, $v;\n\n    while ($pos > 0) {\n        my $parent = ($pos - 1) >> 1;\n        last if $heap->[$parent][0] <= $heap->[$pos][0];\n        @{$heap}[$parent, $pos] = @{$heap}[$pos, $parent];\n        $pos = $parent;\n    }\n}\n\nsub heap_pop($heap) {\n    return pop @$heap if @$heap <= 1;\n    my $top = $heap->[0];\n    $heap->[0] = pop @$heap;\n    sift_down($heap, 0);\n    return $top;\n}\n\nsub divisors_lazy ($n, $callback) {\n\n    # Build factor chains from the prime factorisation of f\n    my @chains;\n    for my $pe (factor_exp($n)) {\n        my ($p, $v) = @$pe;\n        my @C = map { powint($p, $_) } 0 .. $v;\n        push @chains, \\@C;\n    }\n\n    @chains = sort { @$b <=> @$a } @chains;\n\n    # Distribute chains into two arrays\n    my @A = (Math::GMPz->new(1));\n    my @B = (Math::GMPz->new(1));\n\n    for my $C (@chains) {\n        my $ref = (@A < @B) ? \\@A : \\@B;\n        my @new;\n        for my $x (@$ref) {\n            for my $c (@$C) {\n                push @new, $x * $c;\n            }\n        }\n        @$ref = @new;\n    }\n\n    @A = sort { $a <=> $b } @A;\n    @B = sort { $a <=> $b } @B;\n\n    my @h;\n\n    # Seed each row with its smallest product\n    for my $i (0 .. $#A) {\n        push @h, [$A[$i] * $B[0], $i, 0];\n    }\n\n    sift_down(\\@h, $_) for reverse(0 .. ((@h >> 1) - 1));\n\n    my $end_B = $#B;\n\n    while (@h) {\n        my ($k, $i, $j) = @{heap_pop(\\@h)};\n\n        $callback->($k);\n\n        # Advance to the next larger product in the same row\n        if ($j < $end_B) {\n            heap_push(\\@h, [$A[$i] * $B[$j + 1], $i, $j + 1]);\n        }\n    }\n\n    return;\n}\n\ndivisors_lazy(5040, sub ($d) { say $d });\n"
  },
  {
    "path": "Math/divisors_lazy_fast.pl",
    "content": "#!/usr/bin/perl\n\n# Lazily generate the divisors of a given number, in ascending order, by using a Min-Heap.\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory 0.74 qw(:all);\n\nprime_set_config(bigint => 'Math::GMPz');\n\n# Generates and sorts divisors for a specific partition of prime factors\nsub _gen_divs ($factors, $one) {\n    my @res = ($one);\n    foreach my $f (@$factors) {\n        my ($p, $e) = @$f;\n        my @next_res = @res;\n        my $p_pow    = $one * $p;\n        for my $i (1 .. $e) {\n            push @next_res, map { $_ * $p_pow } @res;\n            $p_pow = $p_pow * $p if $i < $e;\n        }\n        @res = @next_res;\n    }\n\n    # Numerically sort the partial divisors\n    return [sort { $a <=> $b } @res];\n}\n\n# Sift down a heap element to maintain Min-Heap property\nsub _sift_down ($h, $idx) {\n    my $len  = scalar @$h;\n    my $item = $h->[$idx];\n    my $val  = $item->[0];\n\n    while (1) {\n        my $left = 2 * $idx + 1;\n        last if $left >= $len;\n        my $right     = $left + 1;\n        my $min_child = $left;\n\n        if ($right < $len && $h->[$right][0] < $h->[$left][0]) {\n            $min_child = $right;\n        }\n        last if $val <= $h->[$min_child][0];\n\n        $h->[$idx] = $h->[$min_child];\n        $idx = $min_child;\n    }\n    $h->[$idx] = $item;\n}\n\n# Helper: Push a new item into the Min-Heap\nsub _push_heap ($h, $item) {\n    push @$h, $item;\n    my $idx = $#$h;\n    my $val = $item->[0];\n\n    while ($idx > 0) {\n        my $parent = int(($idx - 1) / 2);\n        last if $h->[$parent][0] <= $val;\n        $h->[$idx] = $h->[$parent];\n        $idx = $parent;\n    }\n    $h->[$idx] = $item;\n}\n\nsub divisors_lazy ($n, $callback) {\n\n    return if $n < 1;\n    my $one = Math::GMPz->new(1);\n\n    # 1. Factorize N using Math::Prime::Util\n    my @pe = factor_exp($n);\n\n    # 2. Partition factors to balance the number of divisors in A and B\n    # Sort factors by their exponent+1 descending to pack the largest first\n    @pe = sort { $b->[1] <=> $a->[1] } @pe;\n\n    my (@partA, @partB);\n    my ($divA,  $divB) = (1, 1);\n\n    foreach my $f (@pe) {\n        if ($divA <= $divB) {\n            push @partA, $f;\n            $divA *= ($f->[1] + 1);\n        }\n        else {\n            push @partB, $f;\n            $divB *= ($f->[1] + 1);\n        }\n    }\n\n    # 3. Generate the two small sorted arrays of partial divisors\n    my $A = _gen_divs(\\@partA, $one);\n    my $B = _gen_divs(\\@partB, $one);\n\n    # 4. Priority Queue (Min-Heap) for lazy sorted cross-multiplication\n    # Elements in the heap are array references: [ product_value, index_A, index_B ]\n    my @heap = ([$A->[0] * $B->[0], 0, 0]);\n\n    while (@heap) {\n\n        my $curr = $heap[0];\n        my $val  = $curr->[0];\n        my $i    = $curr->[1];\n        my $j    = $curr->[2];\n\n        # Trigger the callback for the absolute smallest next divisor\n        $callback->($val);\n\n        # Determine possible next steps in the A x B matrix\n        my $has_next_j = ($j + 1 < @$B);\n        my $has_next_i = ($j == 0 && $i + 1 < @$A);\n\n        if ($has_next_j && $has_next_i) {\n\n            # Add the new row starter into the heap\n            _push_heap(\\@heap, [$A->[$i + 1] * $B->[0], $i + 1, 0]);\n\n            $curr->[0] = $A->[$i] * $B->[$j + 1];\n            $curr->[2] = $j + 1;\n            _sift_down(\\@heap, 0);\n        }\n        elsif ($has_next_j) {\n\n            # Reuse root\n            $curr->[0] = $A->[$i] * $B->[$j + 1];\n            $curr->[2] = $j + 1;\n            _sift_down(\\@heap, 0);\n        }\n        elsif ($has_next_i) {\n\n            # Reuse root\n            $curr->[0] = $A->[$i + 1] * $B->[0];\n            $curr->[1] = $i + 1;\n            _sift_down(\\@heap, 0);\n        }\n        else {\n            # Exhausted this path, pop from heap entirely\n            my $last = pop @heap;\n            if (@heap) {\n                $heap[0] = $last;\n                _sift_down(\\@heap, 0);\n            }\n        }\n    }\n}\n\ndivisors_lazy(5040, sub ($d) { say $d });\n"
  },
  {
    "path": "Math/divisors_less_than_k.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 04 August 2019\n# https://github.com/trizen\n\n# Generate all the divisors d of n, such that d <= k.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(factor_exp divisors);\n\nsub divisors_le {\n    my ($n, $k) = @_;\n\n    my @d  = (1);\n    my @pp = grep { $_->[0] <= $k } factor_exp($n);\n\n    foreach my $pp (@pp) {\n\n        my ($p, $e) = @$pp;\n\n        my @t;\n        my $r = 1;\n\n        for my $i (1 .. $e) {\n            $r *= $p;\n            foreach my $u (@d) {\n                push(@t, $u * $r) if ($u * $r <= $k);\n            }\n        }\n\n        push @d, @t;\n    }\n\n    return sort { $a <=> $b } @d;\n}\n\n# Generate the divisors of 5040 less than or equal to 42\nsay join ' ', divisors_le(5040, 42);\n"
  },
  {
    "path": "Math/divisors_of_factorial_below_limit.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 18 December 2018\n# https://github.com/trizen\n\n# Generate the divisors of n! below a given limit.\n\nuse 5.020;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(primes todigits vecsum valuation factorial);\n\nsub divisors_of_factorial ($f, $limit = factorial($f)) {\n\n    my @primes = @{primes($f)};\n\n    my @d = (1);\n    foreach my $p (@primes) {\n\n        # Maximum power of p in f!\n        my $pow = ($f - vecsum(todigits($f, $p))) / ($p - 1);\n\n        foreach my $n (@d) {\n            if ($n * $p <= $limit) {\n                last if (valuation($n, $p) >= $pow);\n                push @d, $n * $p;\n            }\n        }\n    }\n\n    return \\@d;\n}\n\nmy $n     = 30;\nmy $limit = 10**12;\n\nmy $d = divisors_of_factorial($n, $limit);\n\nprintf \"There are %s divisors of $n! below $limit\\n\", scalar(@$d);\nprintf \"Sum of divisors of $n! below $limit = %s\\n\", vecsum(@$d);\n\n__END__\nThere are 372197 divisors of 30! below 1000000000000\nSum of divisors of 30! below 1000000000000 = 53793088959503349\n"
  },
  {
    "path": "Math/divisors_of_factorial_in_range_iterator.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 18 December 2018\n# https://github.com/trizen\n\n# Generate the divisors of n! in a given range, using a closure iterator.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Smooth_number\n\nuse 5.020;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(vecmin primes todigits vecsum valuation factorial);\n\nsub divisors_of_factorial_iterator ($f, $low, $high) {\n\n    my @primes = map { [$_, ($f - vecsum(todigits($f, $_))) / ($_ - 1)] } @{primes($f)};\n\n    my @s = map { [1] } 1 .. @primes;\n\n    sub {\n        my $n = 0;\n\n        while ($n < $low) {\n\n            $n = vecmin(map { $_->[0] } @s);\n\n            foreach my $i (0 .. $#primes) {\n                shift(@{$s[$i]}) if ($s[$i][0] == $n);\n                my $p = $primes[$i][0];\n                last if valuation($n, $p) >= $primes[$i][1];\n                push(@{$s[$i]}, $n * $p);\n            }\n        }\n\n        return undef if ($n > $high);\n        return $n;\n    }\n}\n\nmy $n    = 30;\nmy $low  = 10**8;\nmy $high = 10**12;\n\nmy $iter = divisors_of_factorial_iterator($n, $low, $high);\n\nmy $sum = 0;\nfor (my $n = $iter->() ; defined($n) ; $n = $iter->()) {\n    $sum += $n;\n}\nsay \"Sum of divisors of $n! between $low and $high = $sum\";\n\n__END__\nSum of divisors of 30! between 100000000 and 1000000000000 = 53791918385367774\n"
  },
  {
    "path": "Math/dixon_factorization_method.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 28 January 2019\n# https://github.com/trizen\n\n# Simple implementation of Dixon's factorization method.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Dixon%27s_factorization_method\n#   https://trizenx.blogspot.com/2018/10/continued-fraction-factorization-method.html\n\n# Some parts of code inspired by:\n#    https://github.com/martani/Quadratic-Sieve\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Math::GMPz qw();\nuse List::Util qw(first);\nuse ntheory qw(is_prime factor_exp forprimes next_prime);\nuse Math::Prime::Util::GMP qw(is_power vecprod sqrtint rootint gcd urandomb);\n\nsub gaussian_elimination ($rows, $n) {\n\n    my @A   = @$rows;\n    my $m   = $#A;\n    my $ONE = Math::GMPz::Rmpz_init_set_ui(1);\n\n    my @I = map { $ONE << $_ } 0 .. $m;\n\n    my $nrow = -1;\n    my $mcol = $m < $n ? $m : $n;\n\n    foreach my $col (0 .. $mcol) {\n        my $npivot = -1;\n\n        foreach my $row ($nrow + 1 .. $m) {\n            if (Math::GMPz::Rmpz_tstbit($A[$row], $col)) {\n                $npivot = $row;\n                $nrow++;\n                last;\n            }\n        }\n\n        next if ($npivot == -1);\n\n        if ($npivot != $nrow) {\n            @A[$npivot, $nrow] = @A[$nrow, $npivot];\n            @I[$npivot, $nrow] = @I[$nrow, $npivot];\n        }\n\n        foreach my $row ($nrow + 1 .. $m) {\n            if (Math::GMPz::Rmpz_tstbit($A[$row], $col)) {\n                $A[$row] ^= $A[$nrow];\n                $I[$row] ^= $I[$nrow];\n            }\n        }\n    }\n\n    return (\\@A, \\@I);\n}\n\nsub is_smooth_over_prod ($n, $k) {\n\n    state $g = Math::GMPz::Rmpz_init_nobless();\n    state $t = Math::GMPz::Rmpz_init_nobless();\n\n    Math::GMPz::Rmpz_set($t, $n);\n    Math::GMPz::Rmpz_gcd($g, $t, $k);\n\n    while (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {\n        Math::GMPz::Rmpz_remove($t, $t, $g);\n        return 1 if Math::GMPz::Rmpz_cmp_ui($t, 1) == 0;\n        Math::GMPz::Rmpz_gcd($g, $t, $g);\n    }\n\n    return 0;\n}\n\nsub check_factor ($n, $g, $factors) {\n\n    while ($n % $g == 0) {\n\n        $n /= $g;\n        push @$factors, $g;\n\n        if (is_prime($n)) {\n            push @$factors, $n;\n            return 1;\n        }\n    }\n\n    return $n;\n}\n\nsub dixon_factorization ($n, $verbose = 0) {\n\n    local $| = 1;\n\n    # Check for primes and negative numbers\n    return ()   if $n <= 1;\n    return ($n) if is_prime($n);\n\n    # Check for perfect powers\n    if (my $k = is_power($n)) {\n        my @factors = __SUB__->(Math::GMPz->new(rootint($n, $k)), $verbose);\n        return sort { $a <=> $b } ((@factors) x $k);\n    }\n\n    # Check for divisibility by 2\n    if (Math::GMPz::Rmpz_even_p($n)) {\n\n        my $v = Math::GMPz::Rmpz_scan1($n, 0);\n        my $t = $n >> $v;\n\n        my @factors = (2) x $v;\n\n        if ($t > 1) {\n            push @factors, __SUB__->($t, $verbose);\n        }\n\n        return @factors;\n    }\n\n    my $B  = 8 * int(exp(sqrt(log(\"$n\") * log(log(\"$n\"))) / 2));               # B-smooth limit\n    my $nf = 2 * int(exp(sqrt(log(\"$n\") * log(log(\"$n\"))))**(sqrt(2) / 4));    # number of primes in factor-base\n\n    my @factor_base = (2);\n\n    if (length(\"$n\") <= 25) {\n        forprimes {\n            if (Math::GMPz::Rmpz_kronecker_ui($n, $_) >= 0) {\n                push @factor_base, $_;\n            }\n        }\n        3, $B;\n    }\n    else {\n        for (my $p = 3 ; @factor_base < $nf ; $p = next_prime($p)) {\n            if (Math::GMPz::Rmpz_kronecker_ui($n, $p) >= 0) {\n                push @factor_base, $p;\n            }\n        }\n    }\n\n    my %factor_index;\n    @factor_index{@factor_base} = (0 .. $#factor_base);\n\n    my sub exponents_signature (@factors) {\n        my $sig = Math::GMPz::Rmpz_init_set_ui(0);\n\n        foreach my $p (@factors) {\n            if ($p->[1] & 1) {\n                Math::GMPz::Rmpz_setbit($sig, $factor_index{$p->[0]});\n            }\n        }\n\n        return $sig;\n    }\n\n    my $L  = scalar(@factor_base) + 1;                 # maximum number of matrix-rows\n    my $FP = Math::GMPz->new(vecprod(@factor_base));\n\n    if ($verbose) {\n        printf(\"[*] Factoring %s (%s digits)...\\n\\n\", \"$n\", length(\"$n\"));\n        say \"*** Step 1/2: Finding smooth relations ***\";\n        printf(\"Target: %s relations, with B = %s\\n\", $L, $factor_base[-1]);\n    }\n\n    my (@A, @Q);\n\n    my $u = Math::GMPz::Rmpz_init();\n    my $t = Math::GMPz::Rmpz_init();\n    my $v = Math::GMPz::Rmpz_init();\n\n    Math::GMPz::Rmpz_sqrt($u, $n);\n    Math::GMPz::Rmpz_sqrt($t, $n);\n\n    while (1) {\n\n        # u += 1\n        Math::GMPz::Rmpz_add_ui($u, $u, 1);\n\n        # v = (u*u) % n\n        Math::GMPz::Rmpz_powm_ui($v, $u, 2, $n);\n\n        if (is_smooth_over_prod($v, $FP)) {\n            my @factors = factor_exp($v);\n\n            if (@factors) {\n                push @A, exponents_signature(@factors);\n                push @Q, [map { Math::GMPz::Rmpz_init_set($_) } ($u, $v)];\n            }\n\n            if ($verbose) {\n                printf(\"Progress: %d/%d relations.\\r\", scalar(@A), $L);\n            }\n\n            last if (@A >= $L);\n        }\n\n        # t -= 1\n        Math::GMPz::Rmpz_sub_ui($t, $t, 1);\n\n        # v = (t*t) % n\n        Math::GMPz::Rmpz_powm_ui($v, $t, 2, $n);\n        Math::GMPz::Rmpz_sub($v, $n, $v);\n\n        if (is_smooth_over_prod($v, $FP)) {\n            my @factors = factor_exp($v);\n\n            if (@factors) {\n                push @A, exponents_signature(@factors);\n                push @Q, [map { Math::GMPz::Rmpz_init_set($_) } ($t, $v)];\n            }\n\n            if ($verbose) {\n                printf(\"Progress: %d/%d relations.\\r\", scalar(@A), $L);\n            }\n\n            last if (@A >= $L);\n        }\n    }\n\n    if ($verbose) {\n        say \"This step took \", $u -Math::GMPz->new(sqrtint($n)), \" iterations.\";\n        say \"\\n*** Step 2/2: Linear Algebra ***\";\n        say \"Performing Gaussian elimination...\";\n    }\n\n    if (@A < $L) {\n        push @A, map { Math::GMPz::Rmpz_init_set_ui(0) } 1 .. ($L - @A + 1);\n    }\n\n    my ($A, $I) = gaussian_elimination(\\@A, $L - 1);\n\n    my $LR = ((first { $A->[-$_] } 1 .. @$A) // 0) - 1;\n\n    if ($verbose) {\n        say \"Found $LR linear dependencies...\";\n        say \"Finding factors from congruences of squares...\\n\";\n    }\n\n    my @factors;\n    my $rem = $n;\n\n  SOLUTIONS: foreach my $solution (@{$I}[@$I - $LR .. $#$I]) {\n\n        my $X = 1;\n        my $Y = 1;\n\n        foreach my $i (0 .. $#Q) {\n\n            Math::GMPz::Rmpz_tstbit($solution, $i) || next;\n\n            ($X *= $Q[$i][0]) %= $n;\n            ($Y *= $Q[$i][1]);\n\n            my $g = Math::GMPz->new(gcd($X - Math::GMPz->new(sqrtint($Y)), $rem));\n\n            if ($g > 1 and $g < $rem) {\n                if ($verbose) {\n                    say \"`-> found factor: $g\";\n                }\n                $rem = check_factor($rem, $g, \\@factors);\n                last SOLUTIONS if $rem == 1;\n            }\n        }\n    }\n\n    say '' if $verbose;\n\n    my @final_factors;\n\n    foreach my $f (@factors) {\n        if (is_prime($f)) {\n            push @final_factors, $f;\n        }\n        else {\n            push @final_factors, __SUB__->($f, $verbose);\n        }\n    }\n\n    if ($rem != 1) {\n        if ($rem != $n) {\n            push @final_factors, __SUB__->($rem, $verbose);\n        }\n        else {\n            push @final_factors, $rem;\n        }\n    }\n\n    return sort { $a <=> $b } @final_factors;\n}\n\nmy @composites = (\n    @ARGV ? (map { Math::GMPz->new($_) } @ARGV) : do {\n        map { Math::GMPz->new(urandomb($_)) + 2 } 2 .. 60;\n    }\n);\n\n# Run some tests when no argument is provided\nforeach my $n (@composites) {\n\n    my @f = dixon_factorization($n, @ARGV ? 1 : 0);\n\n    say \"$n = \", join(' * ', map { is_prime($_) ? $_ : \"$_ (composite)\" } @f);\n    die 'error' if Math::GMPz->new(vecprod(@f)) != $n;\n}\n"
  },
  {
    "path": "Math/e_from_binomial.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 17 July 2016\n# Website: https://github.com/trizen\n\n# A new identity for e, based on (n+1)^n / n^n, as n->infinity,\n# with the binomial expansion of (n+1)^n derived by the author.\n\n#    n -> ∞\n#     ---\n#     \\     binomial(n, k)\n#     /    ---------------  =  e\n#     ---      n^(n-k)\n#    k = 0\n\nuse 5.014;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload binomial);\n\nmy $n = 5000;\nmy $sum = 0.0;\n\nforeach my $k(0 .. $n) {\n    $sum += binomial($n, $k) / $n**($n-$k);\n}\n\nsay $sum;\n"
  },
  {
    "path": "Math/e_primorial.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 04 September 2015\n# Website: https://github.com/trizen\n\n# Compute a new constant, called e-primorial\n# using the following formula:\n#   1 + sum({n=0, Inf}, 1/n#)\n# where 'n#' is the product of the first n primes.\n\n# Example:\n#   1 + 1/2 + 1/(2*3) + 1/(2*3*5) + 1/(2*3*5*7)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse bignum (try => 'GMP');\nuse ntheory qw(forprimes);\n\nmy $s = 0;\nmy $p = 1;\n\nforprimes {\n    $s += 1 / ($p *= $_);\n}\n1000;\n\nsay $s;\n\n__END__\n0.705230171791800965147431682888248513743607733565505914344254271579448720350814858381153069719904774040199744849124258793026220304812181974452618661012021323159778159738892351792865007915208229244324416883081570696757761526547730409991939570626315095656064297092991040559037018681680261221057850602197069242610518384960529122692938064843534568180026418571495177395781060935455813529379203383024423075030933708131887415\n"
  },
  {
    "path": "Math/ecm_factorization_method.pl",
    "content": "#!/usr/bin/perl\n\n# The elliptic-curve factorization method (ECM), due to Hendrik Lenstra.\n\n# Algorithm presented in the YouTube video:\n#   https://www.youtube.com/watch?v=2JlpeQWtGH8\n\n# See also:\n#   https://en.wikipedia.org/wiki/Lenstra_elliptic-curve_factorization\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::GMPz qw();\nuse experimental qw(signatures);\nuse ntheory qw(is_prime_power logint);\nuse Math::Prime::Util::GMP qw(primes vecprod random_nbit_prime);\n\nsub ecm ($N, $zrange = 200, $plimit = 20000) {\n\n    # Check for perfect powers\n    if (is_prime_power($N, \\my $p)) {\n        return $p;\n    }\n\n    # Make sure `N` is a Math::GMPz object\n    if (ref($N) ne 'Math::GMPz') {\n        $N = Math::GMPz->new(\"$N\");\n    }\n\n    # Primes up to `plimit`\n    my @primes = @{primes($plimit)};\n\n    # Temporary mpz objects\n    my $t  = Math::GMPz::Rmpz_init();\n    my $t1 = Math::GMPz::Rmpz_init();\n    my $t2 = Math::GMPz::Rmpz_init();\n\n    foreach my $z (-$zrange .. $zrange) {\n\n        my $x = Math::GMPz::Rmpz_init_set_ui(0);\n        my $y = Math::GMPz::Rmpz_init_set_ui(1);\n\n        foreach my $p (@primes) {\n\n            my ($xn, $yn);\n            my ($sx, $sy, $k) = ($x, $y, $p**logint($plimit, $p));\n\n            my $first = 1;\n\n            while ($k) {\n\n                if ($k & 1) {\n\n                    if ($first) {\n                        ($xn, $yn) = ($sx, $sy);\n                        $first = 0;\n                    }\n                    else {\n                        Math::GMPz::Rmpz_sub($t, $sx, $xn);\n\n                        if (!Math::GMPz::Rmpz_invert($t2, $t, $N)) {\n                            Math::GMPz::Rmpz_gcd($t2, $t, $N);\n                            Math::GMPz::Rmpz_cmp($t2, $N) ? return $t2 : last;\n                        }\n\n                        my $u = $t2;\n\n                        # u * (sy - yn)\n                        Math::GMPz::Rmpz_sub($t, $sy, $yn);\n                        Math::GMPz::Rmpz_mul($t, $t, $u);\n                        Math::GMPz::Rmpz_mod($t2, $t, $N);\n\n                        my $L = $t2;\n\n                        # L^2 - xn - sx\n                        Math::GMPz::Rmpz_mul($t, $L, $L);\n                        Math::GMPz::Rmpz_sub($t, $t, $xn);\n                        Math::GMPz::Rmpz_sub($t, $t, $sx);\n                        Math::GMPz::Rmpz_mod($t, $t, $N);\n\n                        my $x_sum = Math::GMPz::Rmpz_init_set($t);\n\n                        Math::GMPz::Rmpz_sub($t, $xn, $x_sum);\n                        Math::GMPz::Rmpz_mul($t, $t, $L);\n                        Math::GMPz::Rmpz_sub($t, $t, $yn);\n                        Math::GMPz::Rmpz_mod($t, $t, $N);\n\n                        $yn = Math::GMPz::Rmpz_init_set($t);\n                        $xn = $x_sum;\n                    }\n                }\n\n                Math::GMPz::Rmpz_mul_2exp($t, $sy, 1);\n\n                if (!Math::GMPz::Rmpz_invert($t2, $t, $N)) {\n                    Math::GMPz::Rmpz_gcd($t2, $t, $N);\n                    Math::GMPz::Rmpz_cmp($t2, $N) ? return $t2 : last;\n                }\n\n                my $u = $t2;\n\n                # u * (3 * sx^2 + z) % N\n                Math::GMPz::Rmpz_mul($t, $sx, $sx);\n                Math::GMPz::Rmpz_mul_ui($t, $t, 3);\n\n                $z < 0\n                  ? Math::GMPz::Rmpz_sub_ui($t, $t, -$z)\n                  : Math::GMPz::Rmpz_add_ui($t, $t, $z);\n\n                Math::GMPz::Rmpz_mul($t, $t, $u);\n                Math::GMPz::Rmpz_mod($t2, $t, $N);\n\n                my $L = $t2;\n\n                # (L*L - 2*sx) % N\n                Math::GMPz::Rmpz_mul($t, $L, $L);\n                Math::GMPz::Rmpz_submul_ui($t, $sx, 2);\n                Math::GMPz::Rmpz_mod($t, $t, $N);\n\n                my $x2 = Math::GMPz::Rmpz_init_set($t);\n\n                # (L * (sx - x2) - sy) % N\n                Math::GMPz::Rmpz_sub($t, $sx, $x2);\n                Math::GMPz::Rmpz_mul($t, $t, $L);\n                Math::GMPz::Rmpz_sub($t, $t, $sy);\n                Math::GMPz::Rmpz_mod($t, $t, $N);\n\n                $sy = Math::GMPz::Rmpz_init_set($t);\n                $sx = $x2;\n\n                # Failure when t = 0\n                return $N if !Math::GMPz::Rmpz_sgn($t);\n\n                $k >>= 1;\n            }\n\n            ($x, $y) = ($xn, $yn);\n        }\n    }\n\n    return $N;    # failed to factorize N\n}\n\n# Factoring the 7th Fermat number: 2^128 + 1\nsay ecm(Math::GMPz->new(2)**128 + 1, 100, 8000);    # takes ~1 second\n\nsay \"\\n=> More tests:\";\n\nforeach my $k (10 .. 40) {\n\n    my $n = Math::GMPz->new(vecprod(map { random_nbit_prime($k) } 1 .. 2));\n    my $p = ecm($n, logint($n, 2), logint($n, 2)**2);\n\n    if ($p > 1 and $p < $n) {\n        say \"$n = $p * \", $n / $p;\n    }\n    else {\n        say \"Failed to factor $n\";\n    }\n}\n"
  },
  {
    "path": "Math/elementary_cellular_automaton_generalized.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 16 October 2019\n# https://github.com/trizen\n\n# Generalization of the elementary cellular automaton, by using `n` color-states and looking at `k` neighbors left-to-right.\n\n# For example, a value of `n = 3` and `k = 2` uses three different color-states and looks at 2 neighbors to the left and 2 neighbors to the right.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Cellular_automaton\n#   https://en.wikipedia.org/wiki/Elementary_cellular_automaton\n#   https://rosettacode.org/wiki/Elementary_cellular_automaton\n\n# YouTube lectures:\n#   https://www.youtube.com/watch?v=S3tYzCPuVsA\n#   https://www.youtube.com/watch?v=pGGIE5uhPRQ\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\nuse Algorithm::Combinatorics qw(variations_with_repetition);\n\nsub automaton ($n, $k, $rule, $callback, $iter = 50, $cells = [1]) {\n\n    my @states = variations_with_repetition([0 .. $n - 1], 2 * $k + 1);\n    my @digits = reverse todigits($rule, $n);\n\n    my @lookup;\n\n    foreach my $i (0 .. $#states) {\n        $lookup[fromdigits($states[$i], $n)] = $digits[$i] // 0;\n    }\n\n    my @padding         = (0) x (($iter - scalar(@$cells)) >> 1);\n    my @cells           = (@padding, @$cells, @padding);\n    my @neighbors_range = (-$k .. $k);\n\n    my $len = scalar(@cells);\n\n    for (1 .. ($iter >> 1)) {\n        $callback->(@cells);\n        @cells = @lookup[map {\n            my $i = $_; fromdigits([map { $cells[($i + $_) % $len] } @neighbors_range], $n)\n        } 0 .. $#cells];\n    }\n\n    return @cells;\n}\n\nmy @chars = (' ', '*', '.', '#');\n\nsay \"\\n=> 2x1 Automaton\";\n\nautomaton(2, 1, 90, sub (@row) {\n    say join '', map { $chars[$_] } @row;\n});\n\nsay \"\\n=> 3x1 Automaton\";\n\nautomaton(3, 1, \"843693805713\", sub (@row) {\n    say join '', map { $chars[$_] } @row;\n});\n\nsay \"\\n=> 3x2 Automaton\";\n\nautomaton(3, 2, \"590193390821886729275563552433397050190\", sub (@row) {\n    say join '', map { $chars[$_] } @row;\n}, 80);\n"
  },
  {
    "path": "Math/elliptic-curve_factorization_method.pl",
    "content": "#!/usr/bin/perl\n\n# The elliptic-curve factorization method (ECM), due to Hendrik Lenstra.\n\n# Algorithm presented in the below video:\n#   https://www.youtube.com/watch?v=2JlpeQWtGH8\n\n# See also:\n#   https://en.wikipedia.org/wiki/Lenstra_elliptic-curve_factorization\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::GMPz qw();\nuse experimental qw(signatures);\nuse ntheory qw(is_prime_power logint gcd);\nuse Math::Prime::Util::GMP qw(primes invmod);\n\nsub ecm ($N, $zrange = 100, $plimit = 10000) {\n\n    if (is_prime_power($N, \\my $p)) {\n        return $p;\n    }\n\n    my @primes = @{primes($plimit)};\n\n    foreach my $z (-$zrange .. $zrange) {\n\n        my $x = 0;\n        my $y = 1;\n\n        foreach my $p (@primes) {\n            my $k = $p**logint($plimit, $p);\n\n            my ($xn, $yn);\n            my ($sx, $sy, $t) = ($x, $y, $k);\n\n            my $first = 1;\n\n            while ($t) {\n\n                if ($t & 1) {\n                    if ($first) {\n                        ($xn, $yn) = ($sx, $sy);\n                        $first = 0;\n                    }\n                    else {\n                        my $u = invmod($sx - $xn, $N);\n\n                        if (not defined $u) {\n                            my $d = gcd($sx - $xn, $N);\n                            $d == $N ? last : return $d;\n                        }\n\n                        $u = Math::GMPz->new($u);\n\n                        my $L  = ($u * ($sy - $yn)) % $N;\n                        my $xs = ($L * $L - $xn - $sx) % $N;\n\n                        $yn = ($L * ($xn - $xs) - $yn) % $N;\n                        $xn = $xs;\n                    }\n                }\n\n                my $u = invmod(2 * $sy, $N);\n\n                if (not defined $u) {\n                    my $d = gcd(2 * $sy, $N);\n                    $d == $N ? last : return $d;\n                }\n\n                $u = Math::GMPz->new($u);\n\n                my $L  = ($u * (3 * $sx * $sx + $z)) % $N;\n                my $x2 = ($L * $L - 2 * $sx) % $N;\n\n                $sy = ($L * ($sx - $x2) - $sy) % $N;\n                $sx = $x2;\n\n                $sy || return $N;\n\n                $t >>= 1;\n            }\n            ($x, $y) = ($xn, $yn);\n        }\n    }\n\n    return $N;    # failed\n}\n\nif (@ARGV) {\n\n    my ($str, $B1, $B2) = @ARGV;\n\n    my $n = Math::GMPz->new($str);\n    printf(\"[*] Factoring: %s (%d digits)...\\n\", $n, length(\"$n\"));\n\n    my $factor = ecm($n, $B1 // 100, $B2 // 1000);\n\n    if ($factor > 1 and $factor < $n) {\n        say \"`-> found factor: $factor\";\n        exit 0;\n    }\n    else {\n        say \"`-> no factor found...\";\n        exit 1;\n    }\n}\n\nsay ecm(Math::GMPz->new(\"14304849576137459\"));\nsay ecm(79710615566344993);\nsay ecm(Math::GMPz->new(2)**128 + 1);    # takes ~3.4 seconds\n"
  },
  {
    "path": "Math/elliptic-curve_factorization_method_with_B2_stage.pl",
    "content": "#!/usr/bin/perl\n\n# The elliptic-curve factorization method (ECM), due to Hendrik Lenstra, with B2 stage.\n\n# Code translated from the SymPy file \"ntheory/ecm.py\".\n\npackage Point {\n\n    use 5.036;\n    use Math::Prime::Util::GMP qw(:all);\n\n    if (!defined(&submod)) {\n        *submod = sub ($x, $y, $m) {\n            addmod($x, \"-$y\", $m);\n        };\n    }\n\n    if (!defined(&muladdmod)) {\n        *muladdmod = sub ($x, $y, $z, $m) {\n            addmod(mulmod($x, $y, $m), $z, $m);\n        };\n    }\n\n    sub new {\n        my ($class, $x_cord, $z_cord, $a_24, $mod) = @_;\n        bless {\n               x_cord => $x_cord,\n               z_cord => $z_cord,\n               a_24   => $a_24,\n               mod    => $mod,\n              }, $class;\n    }\n\n    sub add ($self, $Q, $diff) {\n        my $u = mulmod(submod($self->{x_cord}, $self->{z_cord}, $self->{mod}), addmod($Q->{x_cord}, $Q->{z_cord}, $self->{mod}), $self->{mod});\n        my $v = mulmod(addmod($self->{x_cord}, $self->{z_cord}, $self->{mod}), submod($Q->{x_cord}, $Q->{z_cord}, $self->{mod}), $self->{mod});\n        my ($add, $subt) = (addmod($u, $v, $self->{mod}), submod($u, $v, $self->{mod}));\n        my $new_x_cord = mulmod($diff->{z_cord}, mulmod($add, $add, $self->{mod}), $self->{mod});\n        my $new_z_cord = mulmod($diff->{x_cord}, mulmod($subt, $subt, $self->{mod}), $self->{mod});\n        return Point->new($new_x_cord, $new_z_cord, $self->{a_24}, $self->{mod});\n    }\n\n    sub double ($self) {\n        my $u          = powmod(addmod($self->{x_cord}, $self->{z_cord}, $self->{mod}), 2, $self->{mod});\n        my $v          = powmod(submod($self->{x_cord}, $self->{z_cord}, $self->{mod}), 2, $self->{mod});\n        my $diff       = submod($u, $v, $self->{mod});\n        my $new_x_cord = mulmod($u,    $v,                                                $self->{mod});\n        my $new_z_cord = mulmod($diff, muladdmod($self->{a_24}, $diff, $v, $self->{mod}), $self->{mod});\n        return Point->new($new_x_cord, $new_z_cord, $self->{a_24}, $self->{mod});\n    }\n\n    sub mont_ladder ($self, $k) {\n\n        my $Q = $self;\n        my $R = $self->double();\n\n        my @bits = todigits($k, 2);\n        shift @bits;\n\n        foreach my $i (@bits) {\n            if ($i eq '1') {\n                $Q = $R->add($Q, $self);\n                $R = $R->double();\n            }\n            else {\n                $R = $Q->add($R, $self);\n                $Q = $Q->double();\n            }\n        }\n\n        return $Q;\n    }\n}\n\nuse 5.036;\nuse List::Util             qw(uniq min);\nuse Math::Prime::Util::GMP qw(:all);\n\nif (!defined(&submod)) {\n    *submod = sub ($x, $y, $m) {\n        addmod($x, \"-$y\", $m);\n    };\n}\n\nif (!defined(&mulsubmod)) {\n    *mulsubmod = sub ($x, $y, $z, $m) {\n        addmod(mulmod($x, \"-$y\", $m), $z, $m);\n    };\n}\n\nif (!defined(&muladdmod)) {\n    *muladdmod = sub ($x, $y, $z, $m) {\n        addmod(mulmod($x, $y, $m), $z, $m);\n    };\n}\n\nsub ecm_one_factor ($n, $B1 = 10_000, $B2 = 100_000, $max_curves = 200) {\n\n    if (($B1 % 2 == 1) or ($B2 % 2 == 1)) {\n        die \"The Bounds should be even integers\";\n    }\n\n    is_prime($n) && return $n;\n\n    my $D = min(sqrtint($B2), ($B1 >> 1) - 1);\n    my $k = consecutive_integer_lcm($B1);\n\n    my (@S, @beta);\n    my @deltas_list;\n\n    my $r_min  = $B1 + 2 * $D;\n    my $r_max  = $B2 + 2 * $D;\n    my $r_step = 4 * $D;\n\n    for (my $r = $r_min ; $r <= $r_max ; $r += $r_step) {\n        my @deltas;\n        foreach my $q (sieve_primes($r - 2 * $D, $r + 2 * $D)) {\n            push @deltas, ((abs($q - $r) - 1) >> 1);\n        }\n        push @deltas_list, [uniq(@deltas)];\n    }\n\n    for (1 .. $max_curves) {\n\n        # Suyama's parametrization\n        my $sigma = urandomr(6, subint($n, 1));\n        my $u     = mulsubmod($sigma, $sigma, 5, $n);\n        my $v     = mulmod($sigma, 4, $n);\n        my $u_3   = powmod($u, 3, $n);\n\n        my $inv = invmod(mulmod(mulmod($u_3, $v, $n),              16,                       $n), $n) || return gcd(lcm($u_3, $v), $n);\n        my $a24 = mulmod(mulmod(powmod(submod($v, $u, $n), 3, $n), muladdmod(3, $u, $v, $n), $n), $inv, $n);\n\n        my $Q = Point->new($u_3, powmod($v, 3, $n), $a24, $n);\n        $Q = $Q->mont_ladder($k);\n        my $g = gcd($Q->{z_cord}, $n);\n\n        # Stage 1 factor\n        if ($g > 1 and $g < $n) {\n            return $g;\n        }\n\n        # Stage 1 failure. Q.z = 0, Try another curve\n        elsif ($g == $n) {\n            next;\n        }\n\n        # Stage 2 - Improved Standard Continuation\n        $S[0] = $Q;\n        my $Q2 = $Q->double();\n        $S[1]    = $Q2->add($Q, $Q);\n        $beta[0] = mulmod($S[0]->{x_cord}, $S[0]->{z_cord}, $n);\n        $beta[1] = mulmod($S[1]->{x_cord}, $S[1]->{z_cord}, $n);\n\n        foreach my $d (2 .. $D - 1) {\n            $S[$d]    = $S[$d - 1]->add($Q2, $S[$d - 2]);\n            $beta[$d] = mulmod($S[$d]->{x_cord}, $S[$d]->{z_cord}, $n);\n        }\n\n        $g = 1;\n\n        my $W = $Q->mont_ladder(4 * $D);\n        my $T = $Q->mont_ladder($B1 - 2 * $D);\n        my $R = $Q->mont_ladder($B1 + 2 * $D);\n\n        foreach my $deltas (@deltas_list) {\n            my $alpha = mulmod($R->{x_cord}, $R->{z_cord}, $n);\n            foreach my $delta (@$deltas) {\n                $g = mulmod(\n                            $g,\n                            addmod(\n                                   submod(\n                                          mulmod(submod($R->{x_cord}, $S[$delta]->{x_cord}, $n), addmod($R->{z_cord}, $S[$delta]->{z_cord}, $n), $n),\n                                          $alpha, $n\n                                         ),\n                                   $beta[$delta],\n                                   $n\n                                  ),\n                            $n\n                           );\n            }\n\n            # Swap\n            ($T, $R) = ($R, $R->add($W, $T));\n        }\n\n        $g = gcd($n, $g);\n\n        # Stage 2 Factor found\n        if ($g > 1 and $g < $n) {\n            return $g;\n        }\n    }\n\n    # ECM failed, Increase the bounds\n    die \"Increase the bounds\";\n}\n\n# Params from:\n#   https://www.rieselprime.de/ziki/Elliptic_curve_method\n\nmy @ECM_PARAMS = (\n\n    # d      B1     curves\n    [5,  200,        4],\n    [10, 360,        7],\n    [13, 600,        20],\n    [15, 2000,       10],\n    [20, 11000,      90],\n    [25, 50000,      300],\n    [30, 250000,     700],\n    [35, 1000000,    1800],\n    [40, 3000000,    5100],\n    [45, 11000000,   10600],\n    [50, 43000000,   19300],\n    [55, 110000000,  49000],\n    [60, 260000000,  124000],\n    [65, 850000000,  210000],\n    [70, 2900000000, 340000],\n                 );\n\nsub ecm ($n, $B1 = undef, $B2 = undef, $max_curves = undef) {\n\n    $n <= 1 and die \"n must be greater than 1\";\n\n    if (!defined($B1)) {\n        foreach my $row (@ECM_PARAMS) {\n            my ($d, $B1, $curves) = @$row;\n            ## say \":: Trying to find a prime factor with $d digits using B1 = $B1 with $curves curves\";\n            my @f = eval { __SUB__->($n, $B1, $B1 * 20, $curves) };\n            return @f if !$@;\n        }\n    }\n\n    state $primorial = primorial(100_000);\n\n    my @factors;\n    my $g = gcd($n, $primorial);\n\n    if ($g > 1) {\n        push @factors, factor($g);\n        foreach my $p (@factors) {\n            $n = divint($n, powint($p, valuation($n, $p)));\n        }\n    }\n\n    while ($n > 1) {\n        my $factor = eval { ecm_one_factor($n, $B1, $B2, $max_curves) };\n\n        if ($@) {\n            die \"Failed to factor $n: $@\";\n        }\n\n        push @factors, $factor;\n        $n = divint($n, powint($factor, valuation($n, $factor)));\n    }\n\n    @factors = uniq(@factors);\n\n    my @final_factors;\n    foreach my $factor (@factors) {\n        if (is_prime($factor)) {\n            push @final_factors, $factor;\n        }\n        else {\n            push @final_factors, __SUB__->($factor, $B1, $B2, $max_curves);\n        }\n    }\n\n    return sort { $a <=> $b } @final_factors;\n}\n\n# Support for numbers provided as command-line arguments\nif (@ARGV) {\n    foreach my $n (@ARGV) {\n        say \"rad($n) = \", join ' * ', ecm($n);\n    }\n    exit;\n}\n\nsay join ' * ', ecm('314159265358979323');                #=> 317213509 * 990371647\nsay join ' * ', ecm('14304849576137459');                 #=> 16100431 * 888476189\nsay join ' * ', ecm('9804659461513846513');               #=> 4641991 * 2112166839943\nsay join ' * ', ecm('25645121643901801');                 #=> 5394769 * 4753701529\nsay join ' * ', ecm('17177619065692036843');              #=> 2957613037 * 5807933239\nsay join ' * ', ecm('195905123644566489241411490581');    #=> 259719190596553 * 754295911652077\n\nsay join ' * ', ecm(addint(powint(2, 64), 1));            #=> 274177 * 67280421310721\nsay join ' * ', ecm(subint(powint(2, 128), 1));           #=> 3 * 5 * 17 * 257 * 641 * 65537 * 274177 * 6700417 * 67280421310721\nsay join ' * ', ecm(addint(powint(2, 128), 1));           #=> 59649589127497217 * 5704689200685129054721\n\n# Run some tests when no argument is provided\nforeach my $n (map { addint(urandomb($_), 2) } 2 .. 100) {\n    say \"rad($n) = \", join(' * ', map { is_prime($_) ? $_ : \"$_ (composite)\" } ecm($n));\n}\n"
  },
  {
    "path": "Math/elliptic-curve_factorization_method_with_B2_stage_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# The elliptic-curve factorization method (ECM), due to Hendrik Lenstra, with B2 stage. (GMPz implementation)\n\n# Code translated from the SymPy file \"ntheory/ecm.py\".\n\npackage Point {\n\n    use 5.020;\n    use warnings;\n    use Math::GMPz   qw();\n    use experimental qw(signatures);\n\n    sub new {\n        my ($class, $x_cord, $z_cord, $a_24, $mod) = @_;\n        bless {\n               x_cord => $x_cord,\n               z_cord => $z_cord,\n               a_24   => $a_24,\n               mod    => $mod,\n              }, $class;\n    }\n\n    state $t1 = Math::GMPz::Rmpz_init();\n    state $t2 = Math::GMPz::Rmpz_init();\n    state $u  = Math::GMPz::Rmpz_init();\n    state $v  = Math::GMPz::Rmpz_init();\n\n    sub add ($self, $Q, $diff, $new_x_cord = undef, $new_z_cord = undef) {\n\n        Math::GMPz::Rmpz_sub($u, $self->{x_cord}, $self->{z_cord});\n        Math::GMPz::Rmpz_add($t2, $Q->{x_cord}, $Q->{z_cord});\n        Math::GMPz::Rmpz_mul($u, $u, $t2);\n        Math::GMPz::Rmpz_mod($u, $u, $self->{mod});\n\n        Math::GMPz::Rmpz_add($v, $self->{x_cord}, $self->{z_cord});\n        Math::GMPz::Rmpz_sub($t2, $Q->{x_cord}, $Q->{z_cord});\n        Math::GMPz::Rmpz_mul($v, $v, $t2);\n        Math::GMPz::Rmpz_mod($v, $v, $self->{mod});\n\n        Math::GMPz::Rmpz_add($t1, $u, $v);\n        Math::GMPz::Rmpz_sub($t2, $u, $v);\n\n        $new_x_cord //= Math::GMPz::Rmpz_init();\n        $new_z_cord //= Math::GMPz::Rmpz_init();\n\n        Math::GMPz::Rmpz_mul($new_x_cord, $t1,         $t1);\n        Math::GMPz::Rmpz_mul($new_x_cord, $new_x_cord, $diff->{z_cord});\n        Math::GMPz::Rmpz_mod($new_x_cord, $new_x_cord, $self->{mod});\n\n        Math::GMPz::Rmpz_mul($new_z_cord, $t2,         $t2);\n        Math::GMPz::Rmpz_mul($new_z_cord, $new_z_cord, $diff->{x_cord});\n        Math::GMPz::Rmpz_mod($new_z_cord, $new_z_cord, $self->{mod});\n\n        return Point->new($new_x_cord, $new_z_cord, $self->{a_24}, $self->{mod});\n    }\n\n    sub double ($self, $new_x_cord = undef, $new_z_cord = undef) {\n\n        Math::GMPz::Rmpz_add($u, $self->{x_cord}, $self->{z_cord});\n        Math::GMPz::Rmpz_powm_ui($u, $u, 2, $self->{mod});\n\n        Math::GMPz::Rmpz_sub($v, $self->{x_cord}, $self->{z_cord});\n        Math::GMPz::Rmpz_powm_ui($v, $v, 2, $self->{mod});\n\n        Math::GMPz::Rmpz_sub($t1, $u, $v);\n\n        $new_x_cord //= Math::GMPz::Rmpz_init();\n        $new_z_cord //= Math::GMPz::Rmpz_init();\n\n        Math::GMPz::Rmpz_mul($new_x_cord, $u, $v);\n        Math::GMPz::Rmpz_mod($new_x_cord, $new_x_cord, $self->{mod});\n\n        Math::GMPz::Rmpz_mul($t2, $self->{a_24}, $t1);\n        Math::GMPz::Rmpz_add($t2, $t2, $v);\n        Math::GMPz::Rmpz_mod($t2, $t2, $self->{mod});\n        Math::GMPz::Rmpz_mul($new_z_cord, $t1, $t2);\n        Math::GMPz::Rmpz_mod($new_z_cord, $new_z_cord, $self->{mod});\n\n        return Point->new($new_x_cord, $new_z_cord, $self->{a_24}, $self->{mod});\n    }\n\n    sub mont_ladder ($self, $k) {\n\n        my $Q = $self;\n        my $R = $self->double();\n\n        if (ref($k) ne 'Math::GMPz') {\n            $k = Math::GMPz::Rmpz_init_set_str(\"$k\", 10);\n        }\n\n        my $new_x_cord_1 = Math::GMPz::Rmpz_init();\n        my $new_x_cord_2 = Math::GMPz::Rmpz_init();\n        my $new_z_cord_1 = Math::GMPz::Rmpz_init();\n        my $new_z_cord_2 = Math::GMPz::Rmpz_init();\n\n        foreach my $i (split(//, substr(Math::GMPz::Rmpz_get_str($k, 2), 1))) {\n            if ($i eq '1') {\n                $Q = $R->add($Q, $self, $new_x_cord_1, $new_z_cord_1);\n                $R = $R->double($new_x_cord_2, $new_z_cord_2);\n            }\n            else {\n                $R = $Q->add($R, $self, $new_x_cord_2, $new_z_cord_2);\n                $Q = $Q->double($new_x_cord_1, $new_z_cord_1);\n            }\n        }\n\n        return $Q;\n    }\n}\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse Math::GMPz             qw();\nuse List::Util             qw(uniq min);\nuse Math::Prime::Util::GMP qw(:all);\n\nsub ecm_one_factor ($n, $B1 = 10_000, $B2 = 100_000, $max_curves = 200, $seed = undef) {\n\n    if (ref($n) ne 'Math::GMPz') {\n        $n = Math::GMPz::Rmpz_init_set_str(\"$n\", 10);\n    }\n\n    if (($B1 % 2 == 1) or ($B2 % 2 == 1)) {\n        die \"The Bounds should be even integers\";\n    }\n\n    is_prime($n) && return $n;\n\n    my $D = min(sqrtint($B2), ($B1 >> 1) - 1);\n    my $k = Math::GMPz::Rmpz_init_set_str(consecutive_integer_lcm($B1), 10);\n\n    my @S;\n    my @beta = map { Math::GMPz::Rmpz_init() } 1 .. $D;\n    my @xz   = map { [Math::GMPz::Rmpz_init(), Math::GMPz::Rmpz_init()] } 1 .. $D;\n\n    my @deltas_list;\n\n    my $r_min  = $B1 + 2 * $D;\n    my $r_max  = $B2 + 2 * $D;\n    my $r_step = 4 * $D;\n\n    for (my $r = $r_min ; $r <= $r_max ; $r += $r_step) {\n        my @deltas;\n        foreach my $q (sieve_primes($r - 2 * $D, $r + 2 * $D)) {\n            push @deltas, ((abs($q - $r) - 1) >> 1);\n        }\n        push @deltas_list, [uniq(@deltas)];\n    }\n\n    state $u     = Math::GMPz::Rmpz_init();\n    state $v     = Math::GMPz::Rmpz_init();\n    state $u_3   = Math::GMPz::Rmpz_init();\n    state $sigma = Math::GMPz::Rmpz_init();\n    state $t     = Math::GMPz::Rmpz_init();\n    state $t1    = Math::GMPz::Rmpz_init();\n    state $t2    = Math::GMPz::Rmpz_init();\n    state $inv   = Math::GMPz::Rmpz_init();\n    state $a24   = Math::GMPz::Rmpz_init();\n    state $v_3   = Math::GMPz::Rmpz_init();\n    state $alpha = Math::GMPz::Rmpz_init();\n    state $g     = Math::GMPz::Rmpz_init();\n\n    my $state = Math::GMPz::zgmp_randinit_default();\n\n    if (defined($seed)) {\n        Math::GMPz::zgmp_randseed_ui($state, $seed);\n    }\n\n    for (1 .. $max_curves) {\n\n        # Suyama's parametrization\n        Math::GMPz::Rmpz_sub_ui($sigma, $n, 7);\n        Math::GMPz::Rmpz_urandomm($sigma, $state, $sigma, 1);\n        Math::GMPz::Rmpz_add_ui($sigma, $sigma, 6);\n\n        Math::GMPz::Rmpz_mul($u, $sigma, $sigma);\n        Math::GMPz::Rmpz_sub_ui($u, $u, 5);\n        Math::GMPz::Rmpz_mod($u, $u, $n);\n\n        Math::GMPz::Rmpz_mul_2exp($v, $sigma, 2);\n        Math::GMPz::Rmpz_mod($v, $v, $n);\n\n        Math::GMPz::Rmpz_powm_ui($u_3, $u, 3, $n);\n\n        Math::GMPz::Rmpz_mul($t, $u_3, $v);\n        Math::GMPz::Rmpz_mul_2exp($t, $t, 4);\n        Math::GMPz::Rmpz_mod($t, $t, $n);\n\n        Math::GMPz::Rmpz_invert($inv, $t, $n) || return do {\n            Math::GMPz::Rmpz_lcm($g, $u_3, $v);\n            Math::GMPz::Rmpz_gcd($g, $g, $n);\n            Math::GMPz::Rmpz_init_set($g);\n        };\n\n        Math::GMPz::Rmpz_sub($a24, $v, $u);\n        Math::GMPz::Rmpz_powm_ui($a24, $a24, 3, $n);\n\n        Math::GMPz::Rmpz_mul_ui($t, $u, 3);\n        Math::GMPz::Rmpz_add($t, $t, $v);\n        Math::GMPz::Rmpz_mul($a24, $a24, $t);\n        Math::GMPz::Rmpz_mod($a24, $a24, $n);\n        Math::GMPz::Rmpz_mul($a24, $a24, $inv);\n        Math::GMPz::Rmpz_mod($a24, $a24, $n);\n\n        Math::GMPz::Rmpz_powm_ui($v_3, $v, 3, $n);\n\n        my $Q = Point->new($u_3, $v_3, $a24, $n);\n        $Q = $Q->mont_ladder($k);\n        Math::GMPz::Rmpz_gcd($g, $Q->{z_cord}, $n);\n\n        # Stage 1 factor\n        if ($g > 1 and $g < $n) {\n            return Math::GMPz::Rmpz_init_set($g);\n        }\n\n        # Stage 1 failure. Q.z = 0, Try another curve\n        elsif ($g == $n) {\n            next;\n        }\n\n        # Stage 2 - Improved Standard Continuation\n        $S[0] = $Q;\n        my $Q2 = $Q->double($xz[0][0], $xz[0][1]);\n        $S[1] = $Q2->add($Q, $Q, $xz[1][0], $xz[1][1]);\n\n        foreach my $d (0 .. 1) {\n            Math::GMPz::Rmpz_mul($beta[$d], $S[$d]->{x_cord}, $S[$d]->{z_cord});\n            Math::GMPz::Rmpz_mod($beta[$d], $beta[$d], $n);\n        }\n\n        foreach my $d (2 .. $D - 1) {\n            $S[$d] = $S[$d - 1]->add($Q2, $S[$d - 2], $xz[$d][0], $xz[$d][1]);\n            Math::GMPz::Rmpz_mul($beta[$d], $S[$d]->{x_cord}, $S[$d]->{z_cord});\n            Math::GMPz::Rmpz_mod($beta[$d], $beta[$d], $n);\n        }\n\n        Math::GMPz::Rmpz_set_ui($t, 1);\n\n        my $W = $Q->mont_ladder(4 * $D);\n        my $T = $Q->mont_ladder($B1 - 2 * $D);\n        my $R = $Q->mont_ladder($B1 + 2 * $D);\n\n        foreach my $deltas (@deltas_list) {\n\n            Math::GMPz::Rmpz_mul($alpha, $R->{x_cord}, $R->{z_cord});\n            Math::GMPz::Rmpz_mod($alpha, $alpha, $n);\n\n            foreach my $delta (@$deltas) {\n                Math::GMPz::Rmpz_sub($t1, $R->{x_cord}, $S[$delta]->{x_cord});\n                Math::GMPz::Rmpz_add($t2, $R->{z_cord}, $S[$delta]->{z_cord});\n                Math::GMPz::Rmpz_mul($t1, $t1, $t2);\n                Math::GMPz::Rmpz_mod($t1, $t1, $n);\n                Math::GMPz::Rmpz_sub($t1, $t1, $alpha);\n                Math::GMPz::Rmpz_add($t1, $t1, $beta[$delta]);\n                Math::GMPz::Rmpz_mul($t, $t, $t1);\n                Math::GMPz::Rmpz_mod($t, $t, $n);\n            }\n\n            # Swap\n            ($T, $R) = ($R, $R->add($W, $T));\n        }\n\n        Math::GMPz::Rmpz_gcd($g, $t, $n);\n\n        # Stage 2 Factor found\n        if ($g > 1 and $g < $n) {\n            return Math::GMPz::Rmpz_init_set($g);\n        }\n    }\n\n    # ECM failed, Increase the bounds\n    die \"Increase the bounds\";\n}\n\n# Params from:\n#   https://www.rieselprime.de/ziki/Elliptic_curve_method\n\nmy @ECM_PARAMS = (\n\n    # d      B1     curves\n    [5,  200,        4],\n    [10, 360,        7],\n    [13, 600,        20],\n    [15, 2000,       10],\n    [20, 11000,      90],\n    [25, 50000,      300],\n    [30, 250000,     700],\n    [35, 1000000,    1800],\n    [40, 3000000,    5100],\n    [45, 11000000,   10600],\n    [50, 43000000,   19300],\n    [55, 110000000,  49000],\n    [60, 260000000,  124000],\n    [65, 850000000,  210000],\n    [70, 2900000000, 340000],\n                 );\n\nsub ecm ($n, $B1 = undef, $B2 = undef, $max_curves = undef, $seed = undef) {\n\n    if (ref($n) ne 'Math::GMPz') {\n        $n = Math::GMPz::Rmpz_init_set_str(\"$n\", 10);\n    }\n\n    $n <= 1 and die \"n must be greater than 1\";\n\n    if (!defined($B1)) {\n        foreach my $row (@ECM_PARAMS) {\n            my ($d, $B1, $curves) = @$row;\n            ## say \":: Trying to find a prime factor with $d digits using B1 = $B1 with $curves curves\";\n            my @f = eval { __SUB__->($n, $B1, $B1 * 20, $curves, $seed) };\n            return @f if !$@;\n        }\n    }\n\n    state $primorial = primorial(100_000);\n\n    my @factors;\n    my $g = gcd($n, $primorial);\n\n    if ($g > 1) {\n        $n = Math::GMPz::Rmpz_init_set($n);    # copy\n        push @factors, factor($g);\n        my $t = Math::GMPz::Rmpz_init();\n        foreach my $p (@factors) {\n            Math::GMPz::Rmpz_set_ui($t, $p);\n            Math::GMPz::Rmpz_remove($n, $n, $t);\n        }\n    }\n\n    while ($n > 1) {\n        my $factor = eval { ecm_one_factor($n, $B1, $B2, $max_curves, $seed) };\n\n        if ($@) {\n            die \"Failed to factor $n: $@\";\n        }\n\n        push @factors, $factor;\n        $n = Math::GMPz::Rmpz_init_set($n);\n        Math::GMPz::Rmpz_remove($n, $n, $factor);\n    }\n\n    @factors = uniq(@factors);\n\n    my @final_factors;\n    foreach my $factor (@factors) {\n        if (is_prime($factor)) {\n            push @final_factors, $factor;\n        }\n        else {\n            push @final_factors, __SUB__->($factor, $B1, $B2, $max_curves);\n        }\n    }\n\n    return sort { $a <=> $b } @final_factors;\n}\n\n# Support for numbers provided as command-line arguments\nif (@ARGV) {\n    foreach my $n (@ARGV) {\n        say \"rad($n) = \", join ' * ', ecm($n);\n    }\n    exit;\n}\n\nsay join ' * ', ecm('314159265358979323');                #=> 317213509 * 990371647\nsay join ' * ', ecm('14304849576137459');                 #=> 16100431 * 888476189\nsay join ' * ', ecm('9804659461513846513');               #=> 4641991 * 2112166839943\nsay join ' * ', ecm('25645121643901801');                 #=> 5394769 * 4753701529\nsay join ' * ', ecm('17177619065692036843');              #=> 2957613037 * 5807933239\nsay join ' * ', ecm('195905123644566489241411490581');    #=> 259719190596553 * 754295911652077\n\nsay join ' * ', ecm(Math::GMPz->new(2)**64 + 1);          #=> 274177 * 67280421310721\nsay join ' * ', ecm(Math::GMPz->new(2)**128 - 1);         #=> 3 * 5 * 17 * 257 * 641 * 65537 * 274177 * 6700417 * 67280421310721\nsay join ' * ', ecm(Math::GMPz->new(2)**128 + 1);         #=> 59649589127497217 * 5704689200685129054721\n\n# Run some tests when no argument is provided\nforeach my $n (map { Math::GMPz->new(urandomb($_)) + 2 } 2 .. 100) {\n    say \"rad($n) = \", join(' * ', map { is_prime($_) ? $_ : \"$_ (composite)\" } ecm($n));\n}\n"
  },
  {
    "path": "Math/equally_spaced_squares_solutions.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 26 January 2019\n# https://github.com/trizen\n\n# Given a positive integer `n`, find the integer values `k` such that both `k-2*n` and `k+2*n` are squares.\n\n# If `n = 4*x*y`, then `k = 4*(x^2 + y^2)`, with rational values x and y.\n\n# For `n = 18`, we have the following solutions:\n#   a(18) = [45, 85, 325]\n#\n# which produce the following squares:\n#   45 + 2*18 =  9^2  ;  45 - 2*18 =  3^2\n#   85 + 2*18 = 11^2  ;  85 - 2*18 =  7^2\n#  325 + 2*18 = 19^2  ; 325 - 2*18 = 17^2\n\n# See also:\n#   https://oeis.org/A323728\n#   https://en.wikipedia.org/wiki/Difference_of_two_squares\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(divisors sqrtint);\nuse Math::AnyNum qw(:overload min);\n\nsub equally_spaced_squares {\n    my ($n) = @_;\n\n    my $limit = sqrtint($n);\n\n    my @solutions;\n    foreach my $d (divisors($n)) {\n\n        last if $d > $limit;\n\n        my $x = $d;\n        my $y = ($n / $d);\n\n        unshift @solutions, $x**2 + $y**2;\n    }\n\n    return @solutions;\n}\n\nforeach my $n (1 .. 20) {\n    say \"a($n) = [\", join(\", \", equally_spaced_squares($n)), \"]\";\n}\n\nsay '';\nsay \"A323728 = [\", join(', ', map { min equally_spaced_squares($_) } 1 .. 100), \", ...]\";\n\n__END__\na(1) = [2]\na(2) = [5]\na(3) = [10]\na(4) = [8, 17]\na(5) = [26]\na(6) = [13, 37]\na(7) = [50]\na(8) = [20, 65]\na(9) = [18, 82]\na(10) = [29, 101]\na(11) = [122]\na(12) = [25, 40, 145]\na(13) = [170]\na(14) = [53, 197]\na(15) = [34, 226]\na(16) = [32, 68, 257]\na(17) = [290]\na(18) = [45, 85, 325]\na(19) = [362]\na(20) = [41, 104, 401]\n\nA323728 = [2, 5, 10, 8, 26, 13, 50, 20, 18, 29, 122, 25, 170, 53, 34, 32, 290, 45, 362, 41, 58, 125, 530, 52, 50, 173, 90, 65, 842, 61, 962, 80, 130, 293, 74, 72, 1370, 365, 178, 89, 1682, 85, 1850, 137, 106, 533, 2210, 100, 98, 125, 298, 185, 2810, 117, 146, 113, 370, 845, 3482, 136, 3722, 965, 130, 128, 194, 157, 4490, 305, 538, 149, 5042, 145, 5330, 1373, 250, 377, 170, 205, 6242, 164, 162, 1685, 6890, 193, 314, 1853, 850, 185, 7922, 181, 218, 545, 970, 2213, 386, 208, 9410, 245, 202, 200, ...]\n"
  },
  {
    "path": "Math/esthetic_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 31 May 2020\n# https://github.com/trizen\n\n# Fast algorithm for generating esthetic numbers in a given base.\n\n# See also:\n#   https://rosettacode.org/wiki/Esthetic_numbers\n\n# OEIS:\n#   https://oeis.org/A000975 -- base 2\n#   https://oeis.org/A033068 -- base 3\n#   https://oeis.org/A033075 -- base 10\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse ntheory qw(fromdigits todigitstring);\n\nsub generate_esthetic ($root, $upto, $callback, $base = 10) {\n\n    my $v = fromdigits($root, $base);\n\n    return if ($v > $upto);\n    $callback->($v);\n\n    my $t = $root->[-1];\n\n    __SUB__->([@$root, $t + 1], $upto, $callback, $base) if ($t + 1 < $base);\n    __SUB__->([@$root, $t - 1], $upto, $callback, $base) if ($t - 1 >= 0);\n}\n\nsub between_esthetic ($from, $upto, $base = 10) {\n    my @list;\n    foreach my $k (1 .. $base - 1) {\n        generate_esthetic([$k], $upto,\n            sub($n) { push(@list, $n) if ($n >= $from) }, $base);\n    }\n    sort { $a <=> $b } @list;\n}\n\nsub first_n_esthetic ($n, $base = 10) {\n    for (my $m = $n * $n ; 1 ; $m *= $base) {\n        my @list = between_esthetic(1, $m, $base);\n        return @list[0 .. $n - 1] if @list >= $n;\n    }\n}\n\nforeach my $base (2 .. 16) {\n    say \"20 first ${\\(sprintf('%2d', $base))}-esthetic numbers: \",\n        join(', ', first_n_esthetic(20, $base));\n}\n\nsay \"\\nBase 10 esthetic numbers between 100,000,000 and 130,000,000:\";\nfor (my @list = between_esthetic(1e8, 1.3e8) ; @list ;) {\n    say join(' ', splice(@list, 0, 9));\n}\n\n__END__\n20 first  2-esthetic numbers: 1, 2, 5, 10, 21, 42, 85, 170, 341, 682, 1365, 2730, 5461, 10922, 21845, 43690, 87381, 174762, 349525, 699050\n20 first  3-esthetic numbers: 1, 2, 3, 5, 7, 10, 16, 21, 23, 30, 32, 48, 50, 64, 70, 91, 97, 145, 151, 192\n20 first  4-esthetic numbers: 1, 2, 3, 4, 6, 9, 11, 14, 17, 25, 27, 36, 38, 46, 57, 59, 68, 70, 100, 102\n20 first  5-esthetic numbers: 1, 2, 3, 4, 5, 7, 11, 13, 17, 19, 23, 26, 36, 38, 55, 57, 67, 69, 86, 88\n20 first  6-esthetic numbers: 1, 2, 3, 4, 5, 6, 8, 13, 15, 20, 22, 27, 29, 34, 37, 49, 51, 78, 80, 92\n20 first  7-esthetic numbers: 1, 2, 3, 4, 5, 6, 7, 9, 15, 17, 23, 25, 31, 33, 39, 41, 47, 50, 64, 66\n20 first  8-esthetic numbers: 1, 2, 3, 4, 5, 6, 7, 8, 10, 17, 19, 26, 28, 35, 37, 44, 46, 53, 55, 62\n20 first  9-esthetic numbers: 1, 2, 3, 4, 5, 6, 7, 8, 9, 11, 19, 21, 29, 31, 39, 41, 49, 51, 59, 61\n20 first 10-esthetic numbers: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 12, 21, 23, 32, 34, 43, 45, 54, 56, 65\n20 first 11-esthetic numbers: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 23, 25, 35, 37, 47, 49, 59, 61\n20 first 12-esthetic numbers: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 14, 25, 27, 38, 40, 51, 53, 64\n20 first 13-esthetic numbers: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 15, 27, 29, 41, 43, 55, 57\n20 first 14-esthetic numbers: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 16, 29, 31, 44, 46, 59\n20 first 15-esthetic numbers: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 17, 31, 33, 47, 49\n20 first 16-esthetic numbers: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 18, 33, 35, 50\n\nBase 10 esthetic numbers between 100,000,000 and 130,000,000:\n101010101 101010121 101010123 101012101 101012121 101012123 101012321 101012323 101012343\n101012345 101210101 101210121 101210123 101212101 101212121 101212123 101212321 101212323\n101212343 101212345 101232101 101232121 101232123 101232321 101232323 101232343 101232345\n101234321 101234323 101234343 101234345 101234543 101234545 101234565 101234567 121010101\n121010121 121010123 121012101 121012121 121012123 121012321 121012323 121012343 121012345\n121210101 121210121 121210123 121212101 121212121 121212123 121212321 121212323 121212343\n121212345 121232101 121232121 121232123 121232321 121232323 121232343 121232345 121234321\n121234323 121234343 121234345 121234543 121234545 121234565 121234567 123210101 123210121\n123210123 123212101 123212121 123212123 123212321 123212323 123212343 123212345 123232101\n123232121 123232123 123232321 123232323 123232343 123232345 123234321 123234323 123234343\n123234345 123234543 123234545 123234565 123234567 123432101 123432121 123432123 123432321\n123432323 123432343 123432345 123434321 123434323 123434343 123434345 123434543 123434545\n123434565 123434567 123454321 123454323 123454343 123454345 123454543 123454545 123454565\n123454567 123456543 123456545 123456565 123456567 123456765 123456767 123456787 123456789\n"
  },
  {
    "path": "Math/ethiopian_multiplication.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Derived: 13 July 2016\n# Coded: 23 October 2016\n# Website: https://github.com/trizen\n\n# A derivation of the Ethiopian multiplication method (also known as \"Russian multiplication\").\n\n# a*b = sum((floor(a * 2^(-k)) mod 2) * b*2^k, {k = 0, floor(log(a)/log(2))})\n\n# See also:\n#   https://mathworld.wolfram.com/RussianMultiplication.html\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub ethiopian_multiplication {\n    my ($x, $y) = @_;\n\n    my $r = 0;\n    foreach my $k (0 .. log($x) / log(2)) {\n        $r += (($x >> $k) % 2) * ($y << $k);\n    }\n    return $r;\n}\n\nsay ethiopian_multiplication(3,  5);    #=>  15\nsay ethiopian_multiplication(7, 41);    #=> 287\n"
  },
  {
    "path": "Math/ethiopian_multiplication_binary.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Derived: 13 July 2016\n# Coded: 23 October 2016\n# Website: https://github.com/trizen\n\n# A derivation of the Ethiopian multiplication method (also known as \"Russian multiplication\").\n\n# a*b = sum((floor(a * 2^(-k)) mod 2) * b*2^k, {k = 0, floor(log(a)/log(2))})\n\n# See also:\n#   https://mathworld.wolfram.com/RussianMultiplication.html\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(hammingweight todigitstring);\n\nsub ethiopian_multiplication {\n    my ($x, $y) = @_;\n\n    # We can swap \"x\" with \"y\" if \"y\" has a lower Hamming-weight value than \"x\".\n    # This optimization reduces considerably the number of required additions.\n\n    my $h1 = hammingweight($x);\n    my $h2 = hammingweight($y);\n\n    if ($h2 < $h1) {\n        ($x, $y) = ($y, $x);\n    }\n\n    my @r;\n    while ($x > 0) {\n\n        if ($x & 1) {\n            push @r, '0b' . todigitstring($y, 2);\n        }\n\n        $y <<= 1;\n        $x >>= 1;\n    }\n\n    return join('+', @r);\n}\n\nsay ethiopian_multiplication(3,  5);    #=>                  0b101+0b1010\nsay ethiopian_multiplication(63, 7);    #=> 0b111111+0b1111110+0b11111100\n"
  },
  {
    "path": "Math/even_fermat_pseudoprimes_in_range.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 22 February 2023\n# https://github.com/trizen\n\n# Generate all the k-omega even Fermat pseudoprimes in range [a,b]. (not in sorted order)\n\n# Definition:\n#   k-omega primes are numbers n such that omega(n) = k.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://en.wikipedia.org/wiki/Prime_omega_function\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\n# OEIS sequences:\n#   https://oeis.org/A006935 -- Even pseudoprimes to base 2\n#   https://oeis.org/A130433 -- Even pseudoprimes to base 3\n\n# PARI/GP program:\n#   even_fermat_psp(A, B, k, base) = A=max(A, vecprod(primes(k))); (f(m, l, p, j) = my(list=List()); forprime(q=p, sqrtnint(B\\m, j), if(base%q != 0, my(v=m*q, t=q); while(v <= B, my(L=lcm(l, znorder(Mod(base, t)))); if(gcd(L, v) == 1, if(j==1, if(v>=A && if(k==1, !isprime(v), 1) && (v-1)%L == 0, listput(list, v)), list=concat(list, f(v, L, q+1, j-1))), break); v *= q; t *= q))); list); vecsort(Vec(f(2, 1, 3, k-1)));\n\n# FIXME: it doesn't generate all the terms for bases > 2.\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\n\nsub even_fermat_pseudoprimes_in_range ($A, $B, $k, $base) {\n\n    if ($k <= 1) {\n        return;\n    }\n\n    $A = vecmax($A, pn_primorial($k));\n\n    my %seen;\n    my @list;\n\n    sub ($m, $L, $lo, $j) {\n\n        my $hi = rootint(divint($B, $m), $j);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        if ($j == 1) {\n\n            if ($L == 1) {    # optimization\n                foreach my $p (@{primes($lo, $hi)}) {\n\n                    $base % $p == 0 and next;\n\n                    for (my $v = $m * $p ; $v <= $B ; $v *= $p) {\n                        $v >= $A or next;\n                        $k == 1 and is_prime($v) and next;\n                        powmod($base, $v, $v) == $base or next;\n                        push(@list, $v) if !$seen{$v}++;\n                    }\n                }\n                return;\n            }\n\n            my $t = invmod($m, $L);\n            $t > $hi && return;\n            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);\n\n            for (my $p = $t ; $p <= $hi ; $p += $L) {\n                if (is_prime_power($p) and gcd($m, $p) == 1 and gcd($base, $p) == 1) {\n                    my $v = $m * $p;\n                    $v >= $A or next;\n                    $k == 1 and is_prime($v) and next;\n\n                    #($v - 1) % znorder($base, $p) == 0 or next;\n                    powmod($base, $v, $v) == $base or next;\n                    push(@list, $v) if !$seen{$v}++;\n                }\n            }\n\n            return;\n        }\n\n        foreach my $p (@{primes($lo, $hi)}) {\n\n            $base % $p == 0 and next;\n\n            my $z = znorder($base, $p);\n            gcd($m, $z) == 1 or next;\n            my $l = lcm($L, $z);\n\n            for (my ($q, $v) = ($p, $m * $p) ; $v <= $B ; ($q, $v) = ($q * $p, $v * $p)) {\n\n                if ($q > $p) {\n                    powmod($base, $z, $q) == 1 or last;\n                }\n\n                __SUB__->($v, $l, $p + 1, $j - 1);\n            }\n        }\n      }\n      ->(2, 1, 3, $k - 1);\n\n    return sort { $a <=> $b } @list;\n}\n\n# Generate all the even Fermat pseudoprimes to base 2 in range [1, 10^5]\n\nmy $from = 1;\nmy $upto = 1e7;\nmy $base = 2;\n\nmy @arr;\nforeach my $k (1 .. 100) {\n    last if pn_primorial($k) > $upto;\n    push @arr, even_fermat_pseudoprimes_in_range($from, $upto, $k, $base);\n}\n\nsay join(', ', sort { $a <=> $b } @arr);\n\n__END__\n161038, 215326, 2568226, 3020626, 7866046, 9115426\n"
  },
  {
    "path": "Math/even_squarefree_fermat_pseudoprimes_in_range.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 22 February 2023\n# https://github.com/trizen\n\n# Generate all the even squarefree Fermat pseudoprimes to a given base with n prime factors in a given range [A,B]. (not in sorted order)\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\n# PARI/GP program (in range):\n#   even_squarefree_fermat(A, B, k, base=2) = A=max(A, vecprod(primes(k))); (f(m, l, p, k, u=0, v=0) = my(list=List()); if(k==1, forprime(p=u, v, if(base%p != 0, my(t=m*p); if((t-1)%l == 0 && (t-1)%znorder(Mod(base, p)) == 0, listput(list, t)))), forprime(q = p, sqrtnint(B\\m, k), my(t = m*q); if (base%q != 0, my(L=lcm(l, znorder(Mod(base, q)))); if(gcd(L, t) == 1, my(u=ceil(A/t), v=B\\t); if(u <= v, my(r=nextprime(q+1)); if(k==2 && r>u, u=r); list=concat(list, f(t, L, r, k-1, u, v))))))); list); vecsort(Vec(f(2, 1, 2, k-1)));\n\n# PARI/GP program (in range) (version 2):\n#   even_squarefree_fermat(A, B, k, base=2) = A=max(A, vecprod(primes(k))); (f(m, l, lo, k) = my(list=List()); my(hi=sqrtnint(B\\m, k)); if(k==1, forprime(p=max(lo, ceil(A/m)), hi, if(base%p != 0, my(t=m*p); if((t-1)%l == 0 && (t-1)%znorder(Mod(base, p)) == 0, listput(list, t)))), forprime(p=lo, hi, if(base%p != 0, my(z=znorder(Mod(base, p))); if(gcd(m, z) == 1, list=concat(list, f(m*p, lcm(l,z), p+1, k-1)))))); list); vecsort(Vec(f(2, 1, 2, k-1)));\n\n# FIXME: it may not generate all the terms for bases > 2.\n\nuse 5.036;\nuse warnings;\nuse ntheory 0.74 qw(:all);\n\nsub even_squarefree_fermat_pseudoprimes_in_range ($A, $B, $k, $base) {\n\n    $A = vecmax($A, pn_primorial($k));\n\n    if ($k <= 1) {\n        return;\n    }\n\n    my @list;\n\n    sub ($m, $L, $lo, $k) {\n\n        my $hi = rootint(divint($B, $m), $k);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        if ($k == 1) {\n\n            $lo = vecmax($lo, cdivint($A, $m));\n            $lo > $hi && return;\n\n            my $t = invmod($m, $L);\n            $t > $hi && return;\n            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);\n\n            for (my $p = $t ; $p <= $hi ; $p += $L) {\n                if (is_prime($p) and $base % $p != 0) {\n                    if (($m * $p - 1) % znorder($base, $p) == 0) {\n                        push(@list, $m * $p);\n                    }\n                }\n            }\n\n            return;\n        }\n\n        foreach my $p (@{primes($lo, $hi)}) {\n\n            $base % $p == 0 and next;\n\n            my $z = znorder($base, $p);\n            gcd($m, $z) == 1 or next;\n\n            __SUB__->($m * $p, lcm($L, $z), $p + 1, $k - 1);\n        }\n      }\n      ->(2, 1, 3, $k - 1);\n\n    return sort { $a <=> $b } @list;\n}\n\n# Generate all the even squarefree Fermat pseudoprimes to base 2 with 5 prime factors in the range [100, 10^10]\n\nmy $k    = 5;\nmy $base = 2;\nmy $from = 100;\nmy $upto = 1e11;\n\nmy @arr = even_squarefree_fermat_pseudoprimes_in_range($from, $upto, $k, $base);\nsay join(', ', @arr);\n\n__END__\n209665666, 213388066, 377994926, 1066079026, 1105826338, 1423998226, 1451887438, 2952654706, 3220041826, 6182224786, 6381449614, 9548385826, 14184805006, 14965276226, 14973142786, 15369282226, 16732427362, 18411253246, 18661908574, 30789370162, 30910262626, 37130195614, 43487454286, 44849716066, 74562118786, 79204064626, 82284719986, 83720640862, 85898088046, 98730252226\n"
  },
  {
    "path": "Math/exponential_divisors.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 13 September 2023\n# https://github.com/trizen\n\n# Generate the exponential divisors (or e-divisors) of n.\n\n# See also:\n#   https://oeis.org/A051377\n#   https://oeis.org/A322791\n\nuse 5.036;\nuse ntheory qw(:all);\n\nsub exponential_divisors ($n) {\n\n    my @d = (1);\n\n    foreach my $pp (factor_exp($n)) {\n        my ($p, $e) = @$pp;\n\n        my @t;\n        foreach my $k (divisors($e)) {\n            my $r = powint($p, $k);\n            push @t, map { mulint($r, $_) } @d;\n        }\n        @d = @t;\n    }\n\n    return sort { $a <=> $b } @d;\n}\n\nforeach my $n (1 .. 20) {\n    my @edivisors = exponential_divisors($n);\n    say \"e-divisors of $n: [@edivisors]\";\n}\n\n__END__\ne-divisors of 1: [1]\ne-divisors of 2: [2]\ne-divisors of 3: [3]\ne-divisors of 4: [2 4]\ne-divisors of 5: [5]\ne-divisors of 6: [6]\ne-divisors of 7: [7]\ne-divisors of 8: [2 8]\ne-divisors of 9: [3 9]\ne-divisors of 10: [10]\ne-divisors of 11: [11]\ne-divisors of 12: [6 12]\ne-divisors of 13: [13]\ne-divisors of 14: [14]\ne-divisors of 15: [15]\ne-divisors of 16: [2 4 16]\ne-divisors of 17: [17]\ne-divisors of 18: [6 18]\ne-divisors of 19: [19]\ne-divisors of 20: [10 20]\n"
  },
  {
    "path": "Math/factorial_difference_of_prime_squares.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 10 April 2026\n# https://github.com/trizen\n\n# An efficient algorithm for generating pairs of primes (p,q) such that n! = p^2 - q^2.\n\n# Number of pairs of primes (p, q) such that n! = p^2 - q^2:\n#   a(n)=if(n<4,return(0));my(N=n!);sumdiv(vecprod(primes([3,n])),d,my(U=2*gcd(d^n,N));ispseudoprime(abs(N/U-U)/2)&&ispseudoprime((N/U+U)/2));\n\n# Least prime p such that p^2 - n! is the square of a prime:\n#   a(n)=if(n<4,return(0));my(N=n!,L=List());fordiv(vecprod(primes([3,n])),d,my(U=2*gcd(d^n,N));my(p=(N/U+U)/2,q=abs(N/U-U)/2); if(ispseudoprime(q)&&ispseudoprime(p), listput(L, [p, q]))); vecsort(Vec(L))[1][1];\n\n# Least prime q such that q^2 + n! is the square of a prime:\n#   a(n)=if(n<4,return(0));my(N=n!,L=List());fordiv(vecprod(primes([3,n])),d,my(U=2*gcd(d^n,N));my(p=(N/U+U)/2,q=abs(N/U-U)/2); if(ispseudoprime(q)&&ispseudoprime(p), listput(L, [p, q]))); vecsort(Vec(L))[1][2];\n\nuse 5.036;\nuse Math::GMPz;\nuse Math::Prime::Util::GMP qw(\n  sieve_primes factorial divisors vecprod\n  is_euler_plumb_pseudoprime is_prob_prime\n);\n\nsub factorial_difference_of_prime_squares ($n) {\n\n    # No prime pairs can exist for n < 4\n    return () if $n < 4;\n\n    my $N = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_fac_ui($N, $n);\n\n    my $z = Math::GMPz::Rmpz_init();\n    my $U = Math::GMPz::Rmpz_init();\n    my $p = Math::GMPz::Rmpz_init();\n    my $q = Math::GMPz::Rmpz_init();\n\n    my @pairs;\n    foreach my $d (divisors(vecprod(sieve_primes(3, $n)))) {\n\n        # U = 2*gcd(d^n, n!) -- unitary divisor of n!\n        Math::GMPz::Rmpz_set_str($U, \"$d\", 10);\n        Math::GMPz::Rmpz_pow_ui($U, $U, $n);\n        Math::GMPz::Rmpz_gcd($U, $U, $N);\n        Math::GMPz::Rmpz_mul_2exp($U, $U, 1);\n\n        # p = (n!/U + U)/2\n        Math::GMPz::Rmpz_divexact($z, $N, $U);\n        Math::GMPz::Rmpz_add($p, $z, $U);\n        Math::GMPz::Rmpz_div_2exp($p, $p, 1);\n\n        # q = |(n!/U - U)|/2\n        Math::GMPz::Rmpz_sub($q, $z, $U);\n        Math::GMPz::Rmpz_abs($q, $q);\n        Math::GMPz::Rmpz_div_2exp($q, $q, 1);\n\n        if (   is_euler_plumb_pseudoprime($p)\n            && is_euler_plumb_pseudoprime($q)\n            && is_prob_prime($q)\n            && is_prob_prime($p)) {\n            push @pairs, [Math::GMPz::Rmpz_init_set($p), Math::GMPz::Rmpz_init_set($q)];\n        }\n    }\n\n    sort { $a->[0] <=> $b->[0] } @pairs;\n}\n\nforeach my $n (0 .. 30) {\n    my @pairs = factorial_difference_of_prime_squares($n);\n\n    # Check results\n    my $factorial = Math::GMPz->new(factorial($n));\n    $_->[0]**2 - $_->[1]**2 == $factorial or die \"error\" for @pairs;\n\n    # Display results\n    say \"For $n!, there exists \", scalar(@pairs), \" solutions:\";\n    say \"$_->[0]^2 - $_->[1]^2\" for @pairs;\n    say '';\n}\n\n__END__\nFor 0!, there exists 0 solutions:\n\nFor 1!, there exists 0 solutions:\n\nFor 2!, there exists 0 solutions:\n\nFor 3!, there exists 0 solutions:\n\nFor 4!, there exists 1 solutions:\n7^2 - 5^2\n\nFor 5!, there exists 3 solutions:\n13^2 - 7^2\n17^2 - 13^2\n31^2 - 29^2\n\nFor 6!, there exists 3 solutions:\n29^2 - 11^2\n41^2 - 31^2\n181^2 - 179^2\n\nFor 7!, there exists 3 solutions:\n73^2 - 17^2\n83^2 - 43^2\n149^2 - 131^2\n\nFor 8!, there exists 4 solutions:\n223^2 - 97^2\n269^2 - 179^2\n347^2 - 283^2\n1447^2 - 1433^2\n\nFor 9!, there exists 2 solutions:\n1201^2 - 1039^2\n12967^2 - 12953^2\n\nFor 10!, there exists 2 solutions:\n36313^2 - 36263^2\n129607^2 - 129593^2\n\nFor 11!, there exists 2 solutions:\n7109^2 - 3259^2\n36563^2 - 36013^2\n\nFor 12!, there exists 3 solutions:\n45341^2 - 39709^2\n72101^2 - 68699^2\n435731^2 - 435181^2\n\nFor 13!, there exists 3 solutions:\n870517^2 - 866933^2\n5661203^2 - 5660653^2\n20217677^2 - 20217523^2\n\nFor 14!, there exists 4 solutions:\n297377^2 - 35423^2\n661949^2 - 592451^2\n6099959^2 - 6092809^2\n67060549^2 - 67059899^2\n\nFor 15!, there exists 5 solutions:\n3240247^2 - 3031753^2\n4185353^2 - 4026103^2\n40776019^2 - 40759981^2\n46663007^2 - 46648993^2\n53380589^2 - 53368339^2\n\nFor 16!, there exists 2 solutions:\n6847843^2 - 5096093^2\n58136737^2 - 57956513^2\n\nFor 17!, there exists 5 solutions:\n51948199^2 - 48403801^2\n87861751^2 - 85813751^2\n89713543^2 - 87708793^2\n835084871^2 - 834871879^2\n9704457163^2 - 9704438837^2\n\nFor 18!, there exists 3 solutions:\n80015629^2 - 356621^2\n163799983^2 - 142926767^2\n456144379^2 - 449071621^2\n\nFor 19!, there exists 6 solutions:\n390403049^2 - 175412201^2\n908301613^2 - 838669613^2\n1327887233^2 - 1281264767^2\n2057302931^2 - 2027523181^2\n18767444567^2 - 18764203433^2\n14311188285517^2 - 14311188281267^2\n\nFor 20!, there exists 4 solutions:\n1613360743^2 - 412348007^2\n11195989613^2 - 11086806637^2\n28754247503^2 - 28711911247^2\n5453127791537^2 - 5453127568463^2\n\nFor 21!, there exists 4 solutions:\n22511523371^2 - 21346609621^2\n311875323841^2 - 311793403841^2\n260407664689049^2 - 260407664590951^2\n3385299640323773^2 - 3385299640316227^2\n\nFor 22!, there exists 5 solutions:\n34121600333^2 - 6346879667^2\n57095454341^2 - 46215691909^2\n83676315727^2 - 76666323023^2\n3430259922251^2 - 3430096082251^2\n751383593333977^2 - 751383592586023^2\n\nFor 23!, there exists 11 solutions:\n162109085183^2 - 20672173567^2\n656267398957^2 - 636266361043^2\n892205965993^2 - 877598694743^2\n1266766081351^2 - 1256520707399^2\n3401826685091^2 - 3398024834909^2\n8680344828157^2 - 8678855588093^2\n14656797059231^2 - 14655915120481^2\n56312004691573^2 - 56311775148427^2\n77105261510737^2 - 77105093869487^2\n839781670416053^2 - 839781655023947^2\n53413257724968960121^2 - 53413257724968959879^2\n\nFor 24!, there exists 9 solutions:\n949484701001^2 - 530162989751^2\n1834878431671^2 - 1657205617079^2\n3607753595353^2 - 3520715495897^2\n3764762240999^2 - 3681438079001^2\n2240108389503221^2 - 2240108251016971^2\n8303923486852687^2 - 8303923449493937^2\n11378955886483363^2 - 11378955859220387^2\n42562058088586199^2 - 42562058081297449^2\n30515856862740485083^2 - 30515856862740474917^2\n\nFor 25!, there exists 9 solutions:\n5056628950459^2 - 3171480143291^2\n15547146353953^2 - 15040031572703^2\n24829505058341^2 - 24515160847909^2\n78216645569761^2 - 78117427211489^2\n323315014757437^2 - 323291026101187^2\n361050891430769^2 - 361029410149519^2\n48825371059806643^2 - 48825370900962893^2\n289270185997405469^2 - 289270185970594531^2\n869657436831744004459^2 - 869657436831743995541^2\n\nFor 26!, there exists 5 solutions:\n23744121396563^2 - 12668537396563^2\n2420056766080999^2 - 2419973441919001^2\n3076902436019147^2 - 3076836900019147^2\n5286204571667072827^2 - 5286204571628927173^2\n7521024835597405469^2 - 7521024835570594531^2\n\nFor 27!, there exists 6 solutions:\n2760884016693079^2 - 2758911322275671^2\n4373016330764051^2 - 4371771146764051^2\n22393110528219359^2 - 22392867396999391^2\n229834993220225567^2 - 229834969531774433^2\n613526442325000909^2 - 613526433450999091^2\n1298054391195579737777^2 - 1298054391195575543473^2\n\nFor 28!, there exists 8 solutions:\n562608177258653^2 - 107887054397597^2\n1538719341436099^2 - 1436234266092349^2\n5857545513097433^2 - 5831462174566183^2\n30609246539348357^2 - 30604265803348357^2\n30749651390795191^2 - 30744693400826441^2\n99357332502156361^2 - 99355798188125111^2\n20795317161553348577^2 - 20795317154222651423^2\n81191752107687936938791^2 - 81191752107687935061209^2\n\nFor 29!, there exists 10 solutions:\n8107890641155673^2 - 7542952250624423^2\n27713890446749977^2 - 27553910098218727^2\n39950026854848041^2 - 39839212890183209^2\n273496089503346041^2 - 273479924695814791^2\n280729626197308811^2 - 280713877930691189^2\n25398805484533309601^2 - 25398805310474690399^2\n91320372584077338157^2 - 91320372535666661843^2\n60280199575371812669429^2 - 60280199575371739330571^2\n1760604331207163905255501^2 - 1760604331207163902744499^2\n2459025884082733056898909^2 - 2459025884082733055101091^2\n\nFor 30!, there exists 12 solutions:\n38041292277848569^2 - 34378584298317319^2\n72475104448878283^2 - 70621440831121717^2\n3339209683791654313^2 - 3339169965645376937^2\n37741346736786394283^2 - 37741343222697800533^2\n123050184466946838757^2 - 123050183389122932507^2\n193289433625415493109^2 - 193289432939260913141^2\n209816218817173808551^2 - 209816218185066191449^2\n4825773025539501469937^2 - 4825773025512018530063^2\n9044795471839217034017^2 - 9044795471824553747233^2\n24368120467294881310207^2 - 24368120467289438689793^2\n821653821267644252160080707^2 - 821653821267644252159919293^2\n1624646959674835599360040817^2 - 1624646959674835599359959183^2\n"
  },
  {
    "path": "Math/factorial_dsc_algorithm.pl",
    "content": "#!/usr/bin/perl\n\n# The DSC-Factorial algorithm (divide, swing and conquer), by Peter Luschny.\n\n# See also:\n#   https://oeis.org/A000142/a000142.pdf\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\nuse ntheory qw(forprimes);\nuse experimental qw(signatures);\n\nsub Product ($s, $n, $m) {\n    $n >  $m and return 1;\n    $n == $m and return $s->[$n];\n    my $k = ($n + $m) >> 1;\n    Product($s, $n, $k) * Product($s, $k + 1, $m);\n}\n\nsub PrimeSwing($n) {\n    my @factors;\n\n    forprimes {\n        my $prime = $_;\n        my ($q, $p) = ($n, 1);\n\n        while ($q > 0) {\n            $q = int($q / $prime);\n            $p *= $prime if ($q & 1);\n        }\n\n        push(@factors, Math::GMPz::Rmpz_init_set_ui($p)) if ($p > 1);\n    } $n;\n\n    Product(\\@factors, 0, $#factors);\n}\n\nsub Factorial($n) {\n    return 1 if ($n < 2);\n    Factorial($n >> 1)**2 * PrimeSwing($n);\n}\n\nforeach my $n (0 .. 30) {\n    say \"$n! = \", Factorial($n);\n}\n"
  },
  {
    "path": "Math/factorial_expansion_of_reciprocals.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 20 December 2018\n# https://github.com/trizen\n\n# Factorial expansion of reciprocals of natural numbers.\n\n# For n>1, the length of the factorial expansion of 1/n is the n-th Kempner number `k`, such that:\n#   1/n = Sum_{j=0..k} f(j) / j!\n\n# See also:\n#   https://oeis.org/A002034\n#   https://oeis.org/A122416\n#   https://en.wikipedia.org/wiki/Kempner_function\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(factor_exp);\nuse experimental qw(signatures);\nuse Math::AnyNum qw(sum factorial bsearch_le);\n\nsub f ($n, $x) {\n    return $x->floor if ($n == 0);\n    ($x * factorial($n))->floor - (($x * factorial($n - 1))->floor * $n);\n}\n\nsub kempner_function ($n) {\n\n    return 0 if ($n == 1);\n\n    my @f = factor_exp($n);\n    my $x = Math::AnyNum->new_q(1, $n);\n\n    my $min = 2;\n    my $max = $f[-1][0] * $f[-1][1];\n\n    my %seen;\n\n    for (; ;) {\n\n        my $k = bsearch_le(\n            $min, $max,\n            sub {\n                0 <=> f($_, $x);\n            }\n        );\n\n        if ($seen{$k}++) {\n            ++$min;\n            ++$max;\n        }\n\n        if (   f($k + 0, $x) != 0\n            or f($k + 1, $x) != 0\n            or f($k + 2, $x) != 0\n            or f($k + 3, $x) != 0\n        ) {\n            $min = $k + 1;\n            next;\n        }\n\n        if (f($k - 1, $x) == 0) {\n            $max = $k;\n            next;\n        }\n\n        return $k - 1;\n    }\n}\n\nforeach my $n (1 .. 50) {\n\n    my $x = Math::AnyNum->new_q(1, $n);\n    my $k = kempner_function($n);\n\n    my @a = map { f($_, $x) } 0 .. $k;\n    my $r = sum(map { $a[$_] / factorial($_) } 0 .. $k);\n\n    say \"F($r) = [\", join(', ', @a), \"]\";\n    die \"error: $r != $x\" if ($r != $x);\n}\n\nsay \"\\n[2..100] Kempner numbers: \", join(', ', map { kempner_function($_) } 2 .. 100);\n\n__END__\nF(1) = [1]\nF(1/2) = [0, 0, 1]\nF(1/3) = [0, 0, 0, 2]\nF(1/4) = [0, 0, 0, 1, 2]\nF(1/5) = [0, 0, 0, 1, 0, 4]\nF(1/6) = [0, 0, 0, 1]\nF(1/7) = [0, 0, 0, 0, 3, 2, 0, 6]\nF(1/8) = [0, 0, 0, 0, 3]\nF(1/9) = [0, 0, 0, 0, 2, 3, 2]\nF(1/10) = [0, 0, 0, 0, 2, 2]\nF(1/11) = [0, 0, 0, 0, 2, 0, 5, 3, 1, 4, 0, 10]\nF(1/12) = [0, 0, 0, 0, 2]\nF(1/13) = [0, 0, 0, 0, 1, 4, 1, 2, 5, 4, 8, 5, 0, 12]\nF(1/14) = [0, 0, 0, 0, 1, 3, 3, 3]\nF(1/15) = [0, 0, 0, 0, 1, 3]\nF(1/16) = [0, 0, 0, 0, 1, 2, 3]\nF(1/17) = [0, 0, 0, 0, 1, 2, 0, 2, 3, 6, 8, 9, 0, 9, 2, 7, 0, 16]\nF(1/18) = [0, 0, 0, 0, 1, 1, 4]\nF(1/19) = [0, 0, 0, 0, 1, 1, 1, 6, 2, 0, 9, 5, 2, 6, 11, 11, 13, 8, 0, 18]\nF(1/20) = [0, 0, 0, 0, 1, 1]\nF(1/21) = [0, 0, 0, 0, 1, 0, 4, 2]\nF(1/22) = [0, 0, 0, 0, 1, 0, 2, 5, 0, 6, 5, 5]\nF(1/23) = [0, 0, 0, 0, 1, 0, 1, 2, 1, 0, 3, 10, 0, 6, 10, 14, 5, 9, 10, 18, 3, 10, 0, 22]\nF(1/24) = [0, 0, 0, 0, 1]\nF(1/25) = [0, 0, 0, 0, 0, 4, 4, 5, 4, 7, 2]\nF(1/26) = [0, 0, 0, 0, 0, 4, 3, 4, 6, 6, 9, 2, 6, 6]\nF(1/27) = [0, 0, 0, 0, 0, 4, 2, 4, 5, 3]\nF(1/28) = [0, 0, 0, 0, 0, 4, 1, 5]\nF(1/29) = [0, 0, 0, 0, 0, 4, 0, 5, 6, 3, 1, 0, 4, 7, 2, 6, 3, 5, 4, 18, 6, 18, 18, 4, 18, 5, 4, 13, 0, 28]\nF(1/30) = [0, 0, 0, 0, 0, 4]\nF(1/31) = [0, 0, 0, 0, 0, 3, 5, 1, 4, 5, 8, 0, 8, 6, 9, 14, 0, 8, 13, 17, 15, 10, 3, 12, 14, 17, 19, 7, 23, 14, 0, 30]\nF(1/32) = [0, 0, 0, 0, 0, 3, 4, 3, 4]\nF(1/33) = [0, 0, 0, 0, 0, 3, 3, 5, 5, 7, 3, 7]\nF(1/34) = [0, 0, 0, 0, 0, 3, 3, 1, 1, 7, 9, 4, 6, 4, 8, 3, 8, 8]\nF(1/35) = [0, 0, 0, 0, 0, 3, 2, 4]\nF(1/36) = [0, 0, 0, 0, 0, 3, 2]\nF(1/37) = [0, 0, 0, 0, 0, 3, 1, 3, 1, 6, 5, 7, 5, 2, 6, 6, 7, 13, 5, 15, 18, 7, 20, 18, 15, 14, 4, 24, 22, 20, 11, 10, 28, 17, 28, 17, 0, 36]\nF(1/38) = [0, 0, 0, 0, 0, 3, 0, 6, 5, 0, 4, 8, 1, 3, 5, 13, 6, 12, 9, 9]\nF(1/39) = [0, 0, 0, 0, 0, 3, 0, 3, 1, 7, 6, 1, 8, 4]\nF(1/40) = [0, 0, 0, 0, 0, 3]\nF(1/41) = [0, 0, 0, 0, 0, 2, 5, 3, 7, 3, 7, 3, 5, 11, 1, 5, 7, 13, 12, 5, 11, 4, 13, 9, 12, 21, 24, 19, 21, 4, 28, 16, 20, 9, 22, 13, 23, 26, 6, 19, 0, 40]\nF(1/42) = [0, 0, 0, 0, 0, 2, 5, 1]\nF(1/43) = [0, 0, 0, 0, 0, 2, 4, 5, 1, 6, 0, 7, 8, 1, 2, 13, 15, 4, 6, 5, 6, 0, 21, 11, 5, 14, 13, 24, 13, 19, 16, 23, 2, 7, 22, 32, 20, 3, 16, 30, 33, 20, 0, 42]\nF(1/44) = [0, 0, 0, 0, 0, 2, 4, 2, 4, 3, 2, 8]\nF(1/45) = [0, 0, 0, 0, 0, 2, 4]\nF(1/46) = [0, 0, 0, 0, 0, 2, 3, 4, 4, 4, 6, 10, 6, 3, 5, 7, 2, 13, 5, 9, 1, 15, 11, 11]\nF(1/47) = [0, 0, 0, 0, 0, 2, 3, 2, 1, 7, 8, 5, 7, 5, 3, 8, 9, 14, 14, 17, 15, 15, 14, 0, 23, 12, 6, 2, 8, 9, 26, 5, 8, 28, 2, 31, 9, 35, 16, 6, 25, 21, 33, 41, 7, 22, 0, 46]\nF(1/48) = [0, 0, 0, 0, 0, 2, 3]\nF(1/49) = [0, 0, 0, 0, 0, 2, 2, 4, 6, 7, 7, 1, 6, 11, 2]\nF(1/50) = [0, 0, 0, 0, 0, 2, 2, 2, 6, 3, 6]\n\n[2..100] Kempner numbers: 2, 3, 4, 5, 3, 7, 4, 6, 5, 11, 4, 13, 7, 5, 6, 17, 6, 19, 5, 7, 11, 23, 4, 10, 13, 9, 7, 29, 5, 31, 8, 11, 17, 7, 6, 37, 19, 13, 5, 41, 7, 43, 11, 6, 23, 47, 6, 14, 10, 17, 13, 53, 9, 11, 7, 19, 29, 59, 5, 61, 31, 7, 8, 13, 11, 67, 17, 23, 7, 71, 6, 73, 37, 10, 19, 11, 13, 79, 6, 9, 41, 83, 7, 17, 43, 29, 11, 89, 6, 13, 23, 31, 47, 19, 8, 97, 14, 11, 10\n"
  },
  {
    "path": "Math/factorial_from_primes.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 18 July 2016\n# Website: https://github.com/trizen\n\n# A fast algorithm, based on powers of primes,\n# for exactly computing very large factorials.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::GMPz qw(:mpz);\nuse experimental qw(signatures);\nuse ntheory qw(forprimes todigits vecsum);\n\nsub factorial_power ($n, $p) {\n    ($n - vecsum(todigits($n, $p))) / ($p - 1);\n}\n\nsub factorial ($n) {\n\n    my $t = Rmpz_init();\n    my $f = Rmpz_init_set_ui(1);\n\n    Rmpz_mul_2exp($f, $f, my $p = factorial_power($n, 2));\n\n    forprimes {\n        if ($p == 1) {\n            Rmpz_mul_ui($f, $f, $_);\n        }\n        else {\n            Rmpz_ui_pow_ui($t, $_, $p = factorial_power($n, $_));\n            Rmpz_mul($f, $f, $t);\n        }\n    } 3, $n;\n\n    $f;\n}\n\nsay factorial($ARGV[0] // 1234);\n\nfor (0..10) {\n    say factorial($_);\n}\n"
  },
  {
    "path": "Math/factorial_from_primes_simple.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 18 July 2016\n# Website: https://github.com/trizen\n\n# A fast algorithm, based on powers of primes,\n# for exactly computing very large factorials.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse ntheory qw(forprimes);\nuse Math::AnyNum qw(:overload sumdigits);\n\nsub factorial_power ($n, $p) {\n    ($n - sumdigits($n, $p)) / ($p - 1);\n}\n\nsub factorial ($n) {\n\n    my $f = 1;\n\n    forprimes {\n        $f *= $_**factorial_power($n, $_);\n    } $n;\n\n    return $f;\n}\n\nfor my $n (0 .. 50) {\n    say \"$n! = \", factorial($n);\n}\n"
  },
  {
    "path": "Math/factorial_from_primorials.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 21 March 2019\n# https://github.com/trizen\n\n# Given a positive integer n, find the unique integer k such that the product of the primorial of all its prime factors, is equal to n!.\n\n# Example for n = 10:\n#   a(10) = 5040 = 2^4 * 3^2 * 5 * 7\n\n# By mapping each prime factor `p` to `primorial(p)`, we get:\n#\n#   primorial(2)^4 * primorial(3)^2 * primorial(5) * primorial(7) = 10!\n#\n# where `primorial(p)` is the product of primes <= p.\n\n# OEIS sequence by Allan C. Wechsler (Mar 20 2019):\n#   https://oeis.org/A307035\n\n# Efficient formula:\n#   a(n) = a(n-1) * (A319626(n) / A319627(n))\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Memoize qw(memoize);\nuse experimental qw(signatures);\nuse ntheory qw(factor_exp prev_prime);\nuse Math::AnyNum qw(:overload ipow factorial primorial prod);\n\nmemoize('f');\n\nsub g($n) {\n\n    my $prod = 1;\n    foreach my $pp (factor_exp($n)) {\n        my ($p, $e) = @$pp;\n\n        if ($p > 2) {\n            $prod *= (Math::AnyNum->new($p) / prev_prime($p))**$e;\n        }\n        else {\n            $prod *= ipow($p, $e);\n        }\n    }\n\n    return $prod;\n}\n\nsub f($n) {\n    return 1 if ($n <= 1);\n    f($n - 1) * g($n);\n}\n\nsub isok ($n, $v) {\n    prod(map { ipow(primorial($_->[0]), $_->[1]) } factor_exp($v)) == factorial($n);\n}\n\nforeach my $n (1 .. 100) {\n    my $v = f($n);\n    say \"a($n) = $v = \", join(' * ', map { \"$_->[0]^$_->[1]\" } factor_exp($v));\n    isok($n, $v) or die \"error for $n\";\n}\n\n__END__\na(1) = 1 =\na(2) = 2 = 2^1\na(3) = 3 = 3^1\na(4) = 12 = 2^2 * 3^1\na(5) = 20 = 2^2 * 5^1\na(6) = 60 = 2^2 * 3^1 * 5^1\na(7) = 84 = 2^2 * 3^1 * 7^1\na(8) = 672 = 2^5 * 3^1 * 7^1\na(9) = 1512 = 2^3 * 3^3 * 7^1\na(10) = 5040 = 2^4 * 3^2 * 5^1 * 7^1\na(11) = 7920 = 2^4 * 3^2 * 5^1 * 11^1\na(12) = 47520 = 2^5 * 3^3 * 5^1 * 11^1\na(13) = 56160 = 2^5 * 3^3 * 5^1 * 13^1\na(14) = 157248 = 2^6 * 3^3 * 7^1 * 13^1\na(15) = 393120 = 2^5 * 3^3 * 5^1 * 7^1 * 13^1\na(16) = 6289920 = 2^9 * 3^3 * 5^1 * 7^1 * 13^1\na(17) = 8225280 = 2^9 * 3^3 * 5^1 * 7^1 * 17^1\na(18) = 37013760 = 2^8 * 3^5 * 5^1 * 7^1 * 17^1\na(19) = 41368320 = 2^8 * 3^5 * 5^1 * 7^1 * 19^1\na(20) = 275788800 = 2^10 * 3^4 * 5^2 * 7^1 * 19^1\na(21) = 579156480 = 2^9 * 3^5 * 5^1 * 7^2 * 19^1\na(22) = 1820206080 = 2^10 * 3^5 * 5^1 * 7^1 * 11^1 * 19^1\na(23) = 2203407360 = 2^10 * 3^5 * 5^1 * 7^1 * 11^1 * 23^1\na(24) = 26440888320 = 2^12 * 3^6 * 5^1 * 7^1 * 11^1 * 23^1\na(25) = 73446912000 = 2^12 * 3^4 * 5^3 * 7^1 * 11^1 * 23^1\na(26) = 173601792000 = 2^13 * 3^4 * 5^3 * 7^1 * 13^1 * 23^1\na(27) = 585906048000 = 2^10 * 3^7 * 5^3 * 7^1 * 13^1 * 23^1\na(28) = 3281073868800 = 2^12 * 3^7 * 5^2 * 7^2 * 13^1 * 23^1\na(29) = 4137006182400 = 2^12 * 3^7 * 5^2 * 7^2 * 13^1 * 29^1\na(30) = 20685030912000 = 2^12 * 3^7 * 5^3 * 7^2 * 13^1 * 29^1\na(31) = 22111584768000 = 2^12 * 3^7 * 5^3 * 7^2 * 13^1 * 31^1\na(32) = 707570712576000 = 2^17 * 3^7 * 5^3 * 7^2 * 13^1 * 31^1\na(33) = 1667845251072000 = 2^16 * 3^8 * 5^3 * 7^1 * 11^1 * 13^1 * 31^1\na(34) = 4362056810496000 = 2^17 * 3^8 * 5^3 * 7^1 * 11^1 * 17^1 * 31^1\na(35) = 10178132557824000 = 2^17 * 3^7 * 5^3 * 7^2 * 11^1 * 17^1 * 31^1\na(36) = 91603193020416000 = 2^17 * 3^9 * 5^3 * 7^2 * 11^1 * 17^1 * 31^1\na(37) = 109332843282432000 = 2^17 * 3^9 * 5^3 * 7^2 * 11^1 * 17^1 * 37^1\na(38) = 244391061454848000 = 2^18 * 3^9 * 5^3 * 7^2 * 11^1 * 19^1 * 37^1\na(39) = 433238699851776000 = 2^17 * 3^10 * 5^3 * 7^2 * 13^1 * 19^1 * 37^1\na(40) = 5776515998023680000 = 2^20 * 3^9 * 5^4 * 7^2 * 13^1 * 19^1 * 37^1\na(41) = 6401004214026240000 = 2^20 * 3^9 * 5^4 * 7^2 * 13^1 * 19^1 * 41^1\na(42) = 26884217698910208000 = 2^20 * 3^10 * 5^3 * 7^3 * 13^1 * 19^1 * 41^1\na(43) = 28195642952515584000 = 2^20 * 3^10 * 5^3 * 7^3 * 13^1 * 19^1 * 43^1\na(44) = 177229755701526528000 = 2^22 * 3^10 * 5^3 * 7^2 * 11^1 * 13^1 * 19^1 * 43^1\na(45) = 664611583880724480000 = 2^20 * 3^11 * 5^4 * 7^2 * 11^1 * 13^1 * 19^1 * 43^1\na(46) = 1609059624132280320000 = 2^21 * 3^11 * 5^4 * 7^2 * 11^1 * 13^1 * 23^1 * 43^1\na(47) = 1758739589167841280000 = 2^21 * 3^11 * 5^4 * 7^2 * 11^1 * 13^1 * 23^1 * 47^1\na(48) = 42209750140028190720000 = 2^24 * 3^12 * 5^4 * 7^2 * 11^1 * 13^1 * 23^1 * 47^1\na(49) = 82731110274455253811200 = 2^24 * 3^12 * 5^2 * 7^4 * 11^1 * 13^1 * 23^1 * 47^1\na(50) = 459617279302529187840000 = 2^25 * 3^10 * 5^4 * 7^4 * 11^1 * 13^1 * 23^1 * 47^1\na(51) = 901556970939576483840000 = 2^24 * 3^11 * 5^4 * 7^4 * 11^1 * 17^1 * 23^1 * 47^1\na(52) = 4261905680805270650880000 = 2^26 * 3^11 * 5^4 * 7^4 * 13^1 * 17^1 * 23^1 * 47^1\na(53) = 4805978746439986053120000 = 2^26 * 3^11 * 5^4 * 7^4 * 13^1 * 17^1 * 23^1 * 53^1\na(54) = 32440356538469905858560000 = 2^24 * 3^14 * 5^4 * 7^4 * 13^1 * 17^1 * 23^1 * 53^1\na(55) = 84962838553135467724800000 = 2^24 * 3^13 * 5^5 * 7^3 * 11^1 * 13^1 * 17^1 * 23^1 * 53^1\na(56) = 951583791795117238517760000 = 2^27 * 3^13 * 5^4 * 7^4 * 11^1 * 13^1 * 17^1 * 23^1 * 53^1\na(57) = 1595302239185931841044480000 = 2^26 * 3^14 * 5^4 * 7^4 * 11^1 * 13^1 * 19^1 * 23^1 * 53^1\na(58) = 4022936081425393338286080000 = 2^27 * 3^14 * 5^4 * 7^4 * 11^1 * 13^1 * 19^1 * 29^1 * 53^1\na(59) = 4478362807624494470922240000 = 2^27 * 3^14 * 5^4 * 7^4 * 11^1 * 13^1 * 19^1 * 29^1 * 59^1\na(60) = 44783628076244944709222400000 = 2^28 * 3^14 * 5^5 * 7^4 * 11^1 * 13^1 * 19^1 * 29^1 * 59^1\na(61) = 46301717163575281818009600000 = 2^28 * 3^14 * 5^5 * 7^4 * 11^1 * 13^1 * 19^1 * 29^1 * 61^1\na(62) = 98989878073850602507468800000 = 2^29 * 3^14 * 5^5 * 7^4 * 11^1 * 13^1 * 19^1 * 31^1 * 61^1\na(63) = 311818115932629397898526720000 = 2^27 * 3^16 * 5^4 * 7^5 * 11^1 * 13^1 * 19^1 * 31^1 * 61^1\na(64) = 19956359419688281465505710080000 = 2^33 * 3^16 * 5^4 * 7^5 * 11^1 * 13^1 * 19^1 * 31^1 * 61^1\na(65) = 39307980675143584704783974400000 = 2^33 * 3^15 * 5^5 * 7^5 * 13^2 * 19^1 * 31^1 * 61^1\na(66) = 185309051754248327893981593600000 = 2^33 * 3^16 * 5^5 * 7^4 * 11^1 * 13^2 * 19^1 * 31^1 * 61^1\na(67) = 203536171598928491293389619200000 = 2^33 * 3^16 * 5^5 * 7^4 * 11^1 * 13^2 * 19^1 * 31^1 * 67^1\na(68) = 1064650743748241339073114931200000 = 2^35 * 3^16 * 5^5 * 7^4 * 11^1 * 13^1 * 17^1 * 19^1 * 31^1 * 67^1\na(69) = 1933181613648122431474866585600000 = 2^34 * 3^17 * 5^5 * 7^4 * 11^1 * 13^1 * 17^1 * 23^1 * 31^1 * 67^1\na(70) = 9021514197024571346882710732800000 = 2^35 * 3^16 * 5^5 * 7^5 * 11^1 * 13^1 * 17^1 * 23^1 * 31^1 * 67^1\na(71) = 9560112059533500979532424806400000 = 2^35 * 3^16 * 5^5 * 7^5 * 11^1 * 13^1 * 17^1 * 23^1 * 31^1 * 71^1\na(72) = 172082017071603017631583646515200000 = 2^36 * 3^18 * 5^5 * 7^5 * 11^1 * 13^1 * 17^1 * 23^1 * 31^1 * 71^1\na(73) = 176929397834183384325431073177600000 = 2^36 * 3^18 * 5^5 * 7^5 * 11^1 * 13^1 * 17^1 * 23^1 * 31^1 * 73^1\na(74) = 422347594829986143228448368230400000 = 2^37 * 3^18 * 5^5 * 7^5 * 11^1 * 13^1 * 17^1 * 23^1 * 37^1 * 73^1\na(75) = 1759781645124942263451868200960000000 = 2^36 * 3^17 * 5^7 * 7^5 * 11^1 * 13^1 * 17^1 * 23^1 * 37^1 * 73^1\na(76) = 7867259119382094824843646074880000000 = 2^38 * 3^17 * 5^7 * 7^5 * 11^1 * 13^1 * 19^1 * 23^1 * 37^1 * 73^1\na(77) = 17307970062640608614656021364736000000 = 2^38 * 3^17 * 5^6 * 7^5 * 11^2 * 13^1 * 19^1 * 23^1 * 37^1 * 73^1\na(78) = 61364621131180339633780439384064000000 = 2^38 * 3^18 * 5^6 * 7^5 * 11^1 * 13^2 * 19^1 * 23^1 * 37^1 * 73^1\na(79) = 66408288621414340151625407004672000000 = 2^38 * 3^18 * 5^6 * 7^5 * 11^1 * 13^2 * 19^1 * 23^1 * 37^1 * 79^1\na(80) = 1770887696571049070710010853457920000000 = 2^42 * 3^17 * 5^7 * 7^5 * 11^1 * 13^2 * 19^1 * 23^1 * 37^1 * 79^1\na(81) = 8965118963890935920469429945630720000000 = 2^38 * 3^21 * 5^7 * 7^5 * 11^1 * 13^2 * 19^1 * 23^1 * 37^1 * 79^1\na(82) = 19868642028082614742661979879505920000000 = 2^39 * 3^21 * 5^7 * 7^5 * 11^1 * 13^2 * 19^1 * 23^1 * 41^1 * 79^1\na(83) = 20874649219377937008113219367075840000000 = 2^39 * 3^21 * 5^7 * 7^5 * 11^1 * 13^2 * 19^1 * 23^1 * 41^1 * 83^1\na(84) = 175347053442774670868151042683437056000000 = 2^40 * 3^22 * 5^6 * 7^6 * 11^1 * 13^2 * 19^1 * 23^1 * 41^1 * 83^1\na(85) = 382166654939380692917765093028003840000000 = 2^40 * 3^21 * 5^7 * 7^6 * 11^1 * 13^1 * 17^1 * 19^1 * 23^1 * 41^1 * 83^1\na(86) = 801617861580164380266531658546544640000000 = 2^41 * 3^21 * 5^7 * 7^6 * 11^1 * 13^1 * 17^1 * 19^1 * 23^1 * 43^1 * 83^1\na(87) = 1516103346901615240938875093338030080000000 = 2^40 * 3^22 * 5^7 * 7^6 * 11^1 * 13^1 * 17^1 * 19^1 * 29^1 * 43^1 * 83^1\na(88) = 19059584932477448743231572601963806720000000 = 2^43 * 3^22 * 5^7 * 7^5 * 11^2 * 13^1 * 17^1 * 19^1 * 29^1 * 43^1 * 83^1\na(89) = 20437386252897505278886867006925045760000000 = 2^43 * 3^22 * 5^7 * 7^5 * 11^2 * 13^1 * 17^1 * 19^1 * 29^1 * 43^1 * 89^1\na(90) = 153280396896731289591651502551937843200000000 = 2^42 * 3^23 * 5^8 * 7^5 * 11^2 * 13^1 * 17^1 * 19^1 * 29^1 * 43^1 * 89^1\na(91) = 253609383956409951869823395131388067840000000 = 2^42 * 3^23 * 5^7 * 7^6 * 11^1 * 13^2 * 17^1 * 19^1 * 29^1 * 43^1 * 89^1\na(92) = 1228003332841563977474934334320405381120000000 = 2^44 * 3^23 * 5^7 * 7^6 * 11^1 * 13^2 * 17^1 * 23^1 * 29^1 * 43^1 * 89^1\na(93) = 1969039826797680170778774018824098283520000000 = 2^43 * 3^24 * 5^7 * 7^6 * 11^1 * 13^2 * 17^1 * 23^1 * 31^1 * 43^1 * 89^1\na(94) = 4304412644627486884958250180685238108160000000 = 2^44 * 3^24 * 5^7 * 7^6 * 11^1 * 13^2 * 17^1 * 23^1 * 31^1 * 47^1 * 89^1\na(95) = 8018023553717867726883015042452894515200000000 = 2^44 * 3^23 * 5^8 * 7^6 * 11^1 * 13^2 * 19^1 * 23^1 * 31^1 * 47^1 * 89^1\na(96) = 384865130578457650890384722037738936729600000000 = 2^48 * 3^24 * 5^8 * 7^6 * 11^1 * 13^2 * 19^1 * 23^1 * 31^1 * 47^1 * 89^1\na(97) = 419459749057420136363677730760232324300800000000 = 2^48 * 3^24 * 5^8 * 7^6 * 11^1 * 13^2 * 19^1 * 23^1 * 31^1 * 47^1 * 97^1\na(98) = 1644282216305086934545616704580110711259136000000 = 2^49 * 3^24 * 5^6 * 7^8 * 11^1 * 13^2 * 19^1 * 23^1 * 31^1 * 47^1 * 97^1\na(99) = 5813712121935843090000573348336820014809088000000 = 2^47 * 3^26 * 5^6 * 7^7 * 11^2 * 13^2 * 19^1 * 23^1 * 31^1 * 47^1 * 97^1\na(100) = 64596801354842701000006370537075777942323200000000 = 2^49 * 3^24 * 5^8 * 7^7 * 11^2 * 13^2 * 19^1 * 23^1 * 31^1 * 47^1 * 97^1\n"
  },
  {
    "path": "Math/factorial_from_trinomial_coefficients.pl",
    "content": "#!/usr/bin/perl\n\n# An efficient algorithm for computing n! using trinomial coefficients.\n\n# See also:\n#   https://oeis.org/A056040\n#   https://oeis.org/A000142/a000142.pdf\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\nuse experimental qw(signatures);\n\nsub trinomial ($m, $n, $o) {\n\n    my $prod = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_bin_uiui($prod, $m + $n + $o, $o);\n\n    if ($n) {\n        my $t = Math::GMPz::Rmpz_init();\n        Math::GMPz::Rmpz_bin_uiui($t, $m + $n, $n);\n        Math::GMPz::Rmpz_mul($prod, $prod, $t);\n    }\n\n    return $prod;\n}\n\nsub Factorial($n) {\n    return 1 if ($n < 2);\n    Factorial($n >> 1)**2 * trinomial($n >> 1, $n % 2, $n >> 1);\n}\n\nforeach my $n (0 .. 30) {\n    say \"$n! = \", Factorial($n);\n}\n"
  },
  {
    "path": "Math/factorial_in_half_steps.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 22 August 2015\n# Website: https://github.com/trizen\n\n# A new algorithm to compute n! in int(n/2) iterations, instead of n.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\n#----------------------------------------------\n## The algorithm\n#----------------------------------------------\n# 6! = 1 * 2 * 3 * 4 * 5 * 6\n#\n#    = 1*6 * 2*5 * 3*4\n#    =   6 *  10 *  12\n#\n#    = (7*1 - 1^2) * (7*2 - 2^2) * (7*3 - 3^2)\n#    =     1*(7-1) *     2*(7-2) *     3*(7-3)\n#----------------------------------------------\n\nsub factorial {\n    my ($n) = @_;\n\n    use integer;\n\n    my $p = 1;\n    my $d = $n / 2;\n    my $m = $n % 2;\n    my $k = $n + 1;\n\n    foreach my $i (1 .. $d) {\n        $p *= $i * ($k - $i);\n    }\n\n    $m ? $p * ($k / 2) : $p;\n}\n\nforeach my $i (1 .. 15) {\n    say \"$i! = \", factorial($i);\n}\n"
  },
  {
    "path": "Math/factorions_in_base_n.pl",
    "content": "#!/usr/bin/perl\n\n# Find all the factorions in base n.\n\n# See also:\n#   https://oeis.org/A193163\n#   https://rosettacode.org/wiki/Factorions\n\nuse 5.020;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\nuse Algorithm::Combinatorics qw(combinations_with_repetition);\n\nsub max_power ($base = 10) {\n    my $m = 1;\n    my $f = factorial($base-1);\n    while ($m * $f >= $base**($m-1)) {\n        $m += 1;\n    }\n    return $m-1;\n}\n\nsub factorions ($base = 10) {\n\n    my @result;\n    my @digits    = (0 .. $base-1);\n    my @factorial = map { factorial($_) } @digits;\n\n    foreach my $k (1 .. max_power($base)) {\n        my $iter = combinations_with_repetition(\\@digits, $k);\n        while (my $comb = $iter->next) {\n            my $n = vecsum(map { $factorial[$_] } @$comb);\n            if (join(' ', sort { $a <=> $b } todigits($n, $base)) eq join(' ', @$comb)) {\n                push @result, $n;\n            }\n        }\n    }\n\n    return @result;\n}\n\nforeach my $base (2 .. 14) {\n    my @r = factorions($base);\n    say \"Factorions in base $base are (@r)\";\n}\n\n__END__\nFactorions in base 2 are (1 2)\nFactorions in base 3 are (1 2)\nFactorions in base 4 are (1 2 7)\nFactorions in base 5 are (1 2 49)\nFactorions in base 6 are (1 2 25 26)\nFactorions in base 7 are (1 2)\nFactorions in base 8 are (1 2)\nFactorions in base 9 are (1 2 41282)\nFactorions in base 10 are (1 2 145 40585)\nFactorions in base 11 are (1 2 26 48 40472)\nFactorions in base 12 are (1 2)\nFactorions in base 13 are (1 2 519326767)\nFactorions in base 14 are (1 2 12973363226)\n"
  },
  {
    "path": "Math/factorization_with_difference_of_prime_factors.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 09 August 2017\n# https://github.com/trizen\n\n# Theorem:\n#   If the absolute difference between the prime factors of a\n#   semiprime `n` is known, then `n` can be factored in polynomial time.\n\n# For example:\n#   n = 97 * 43\n#   n = 4171\n#\n#   d = 97 - 43\n#   d = 54\n\n# Then the factors of `n` are:\n#   43 = abs((-54 + sqrt(54^2 + 4*4171)) / 2)\n#   97 = abs((-54 - sqrt(54^2 + 4*4171)) / 2)\n\n# In general:\n#   n = p * q\n#   d = abs(p - q)\n\n# From which `n` can be factored as:\n#   n = abs((-d + sqrt(d^2 + 4*n)) / 2) *\n#       abs((-d - sqrt(d^2 + 4*n)) / 2)\n#\n\n# Based on the following quadratic equation:\n#   x^2 + (a - b)*x - a*b = 0\n#\n# which has the solutions:\n#   x₁ = -a\n#   x₂ = +b\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(random_nbit_prime);\nuse Math::AnyNum qw(:overload isqrt);\n\nmy $p = Math::AnyNum->new(random_nbit_prime(100));\nmy $q = Math::AnyNum->new(random_nbit_prime(100));\n\nmy $d = abs($p - $q);\nmy $n = $p * $q;\n\nsay \"n = $p * $q\";\nsay \"d = $d\";\n\nsub integer_quadratic_formula {\n    my ($x, $y, $z) = @_;\n\n    (\n        ((-$y + isqrt($y**2 - 4 * $x * $z)) / (2 * $x)),\n        ((-$y - isqrt($y**2 - 4 * $x * $z)) / (2 * $x)),\n    );\n}\n\nmy ($x1, $x2) = integer_quadratic_formula(1, $d, -$n);\n\nprintf(\"n = %s * %s\\n\", abs($x1), abs($x2));\n\nif (abs($x1) * abs($x2) != $n) {\n    die \"error: $x1 * $x2 != $n\\n\";\n}\n"
  },
  {
    "path": "Math/farey_rational_approximation.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 08 February 2018\n# https://github.com/trizen\n\n# Farey rational approximation of a real number.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Farey_sequence\n#   https://en.wikipedia.org/wiki/Stern%E2%80%93Brocot_tree\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload pi);\n\nsub farey_approximation ($r, $eps = 1e-48) {\n\n    my ($a, $b, $c, $d) = (0, 1, 1, 0);\n\n    while (1) {\n        my $m = ($a + $c) / ($b + $d);\n\n        if ($m < $r) {\n            ($a, $b) = $m->nude;\n        }\n        elsif ($m > $r) {\n            ($c, $d) = $m->nude;\n        }\n        else {\n            return $m;\n        }\n\n        if (abs($r - $m) <= $eps) {\n            return $m;\n        }\n    }\n}\n\nsay farey_approximation(pi);            #=> 2857198258041217165097342/909474452321624805685313\nsay farey_approximation(sqrt(2));       #=> 1572584048032918633353217/1111984844349868137938112\n"
  },
  {
    "path": "Math/faulhaber_s_formula.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 03 September 2015\n# Website: https://github.com/trizen\n\n# The formula for calculating the sum of consecutive\n# numbers raised to a given power, such as:\n#    1^p + 2^p + 3^p + ... + n^p\n# where p is a positive integer.\n\n# See also: https://en.wikipedia.org/wiki/Faulhaber%27s_formula\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload binomial);\n\n# This function returns the nth Bernoulli number\n# See: https://en.wikipedia.org/wiki/Bernoulli_number\nsub bernoulli_number {\n    my ($n) = @_;\n\n    return 0 if $n > 1 && $n % 2;    # Bn = 0 for all odd n > 1\n\n    my @A;\n    for my $m (0 .. $n) {\n        $A[$m] = 1 / ($m + 1);\n\n        for (my $j = $m ; $j > 0 ; $j--) {\n            $A[$j - 1] = $j * ($A[$j - 1] - $A[$j]);\n        }\n    }\n\n    return $A[0];                    # which is Bn\n}\n\n# The Faulhaber's formula\n# See: https://en.wikipedia.org/wiki/Faulhaber%27s_formula\nsub faulhaber_s_formula {\n    my ($p, $n) = @_;\n\n    my $sum = 0;\n    for my $j (0 .. $p) {\n        $sum += binomial($p + 1, $j) * bernoulli_number($j) * ($n + 1)**($p + 1 - $j);\n    }\n\n    $sum / ($p + 1);\n}\n\n# Alternate expression using Bernoulli polynomials\n# See: https://en.wikipedia.org/wiki/Faulhaber%27s_formula#Alternate_expressions\nsub bernoulli_polynomials {\n    my ($n, $x) = @_;\n\n    my $sum = 0;\n    for my $k (0 .. $n) {\n        $sum += binomial($n, $k) * bernoulli_number($n - $k) * $x**$k;\n    }\n\n    $sum;\n}\n\nsub faulhaber_s_formula_2 {\n    my ($p, $n) = @_;\n    1 + (bernoulli_polynomials($p + 1, $n + 1) - bernoulli_polynomials($p + 1, 1)) / ($p + 1);\n}\n\n# Test for 1^4 + 2^4 + 3^4 + ... + 10^4\nforeach my $i (0 .. 10) {\n    say \"$i: \", faulhaber_s_formula(4, $i);\n    say \"$i: \", faulhaber_s_formula_2(4, $i);\n}\n"
  },
  {
    "path": "Math/fermat_factorization_method.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 16 March 2018\n# https://github.com/trizen\n\n# A simple implementation of Fermat's factorization method.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Fermat%27s_factorization_method\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse ntheory qw(is_prime vecprod);\nuse Math::AnyNum qw(:overload isqrt is_square valuation);\n\nsub fermat_factorization ($n) {\n\n    # Check for primes and negative numbers\n    return ()   if ($n <= 1);\n    return ($n) if is_prime($n);\n\n    # Check for divisibility by 2\n    if (!($n & 1)) {\n        my $v = valuation($n, 2);\n        return ((2) x $v, __SUB__->($n >> $v));\n    }\n\n    my $q = 2 * isqrt($n);\n\n    while (!is_square($q * $q - 4 * $n)) {\n        $q += 2;\n    }\n\n    my $p = ($q + isqrt($q * $q - 4 * $n)) >> 1;\n\n    return sort { $a <=> $b } (\n        __SUB__->($p),\n        __SUB__->($n / $p),\n    );\n}\n\nforeach my $n (160587846247027, 5040, 65127835124, 6469693230) {\n\n    my @f = fermat_factorization($n);\n    say join(' * ', @f), \" = $n\";\n\n    die 'error' if vecprod(@f) != $n;\n}\n"
  },
  {
    "path": "Math/fermat_factorization_method_2.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 13 September 2017\n# https://github.com/trizen\n\n# Fermat's factorization method.\n\n# Theorem:\n#   If the absolute difference between the prime factors of a\n#   semiprime `n` is known, then `n` can be factored in polynomial time.\n\n# Based on the following quadratic equation:\n#   x^2 + (a - b)*x - a*b = 0\n#\n# which has the solutions:\n#   x₁ = -a\n#   x₂ = +b\n\n# See also:\n#   https://en.wikipedia.org/wiki/Fermat%27s_factorization_method\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(vecprod sqrtint is_prime is_square valuation);\n\nsub fermat_factorization ($n) {\n\n    # Check for primes and negative numbers\n    return ()   if ($n <= 1);\n    return ($n) if is_prime($n);\n\n    # Check for divisibility by 2\n    if (!($n & 1)) {\n        my $v = valuation($n, 2);\n        return ((2) x $v, __SUB__->($n >> $v));\n    }\n\n    my $p = sqrtint($n);\n    my $q = $p * $p - $n;\n\n    until (is_square($q)) {\n        $q += 2 * $p++ + 1;\n    }\n\n    my $s = sqrtint($q);\n\n    my ($x1, $x2) = (\n        ($p + $s),\n        ($p - $s),\n    );\n\n    return sort { $a <=> $b } (\n        __SUB__->($x1),\n        __SUB__->($x2)\n    );\n}\n\nforeach my $n (160587846247027, 5040, 65127835124, 6469693230) {\n\n    my @f = fermat_factorization($n);\n    say join(' * ', @f), \" = $n\";\n\n    die 'error' if vecprod(@f) != $n;\n}\n"
  },
  {
    "path": "Math/fermat_frobenius_quadratic_primality_test.pl",
    "content": "#!/usr/bin/perl\n\n# A very strong primality test, with no counter-examples known.\n\n# Similar to the Baillie–PSW primality test, but instead of performing a Lucas test, we perform a Frobenius quadratic test.\n\n# Given an odd integer n, that is not a perfect power:\n#   1. Perform a base-2 Fermat test.\n#   2. Find the first D in the sequence 5, −7, 9, −11, 13, −15, ... for which the Jacobi symbol (D/n) is −1.\n#      Set P = 1 and Q = (1 − D) / 4.\n#   3. Perform a Frobenius quadratic test with x^2-Px+Q.\n\n# See also:\n#   https://oeis.org/A212424\n#   https://en.wikipedia.org/wiki/Frobenius_pseudoprime\n#   https://en.wikipedia.org/wiki/Quadratic_Frobenius_test\n#   https://en.wikipedia.org/wiki/Baillie%E2%80%93PSW_primality_test\n\nuse 5.020;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse ntheory qw(\n    kronecker is_power is_prime\n    is_frobenius_pseudoprime powmod\n);\n\nsub strong_frobenius_primality_test ($n) {\n\n    return 0 if ($n <= 1);\n    return 1 if ($n == 2);\n    return 0 if is_power($n);\n\n    powmod(2, $n - 1, $n) == 1 or return 0;\n\n    my ($P, $Q) = (1, 0);\n\n    for (my $k = 2 ; ; ++$k) {\n        my $D = (-1)**$k * (2 * $k + 1);\n\n        if (kronecker($D, $n) == -1) {\n            $Q = (1 - $D) / 4;\n            last;\n        }\n    }\n\n    is_frobenius_pseudoprime($n, $P, $Q);\n}\n\nmy $count = 0;\nforeach my $n (1 .. 1e6) {\n    if (strong_frobenius_primality_test($n)) {\n        if (not is_prime($n)) {\n            say \"Counter-example: $n\";\n        }\n        ++$count;\n    }\n    elsif (is_prime($n)) {\n        say \"Missed a prime: $n\";\n    }\n}\n\nsay \"There are $count primes below 10^6\";\n"
  },
  {
    "path": "Math/fermat_overpseudoprimes_generation.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 28 January 2019\n# Edit: 12 November 2022\n# https://github.com/trizen\n\n# A new algorithm for generating Fermat overpseudoprimes to multiple bases.\n\n# See also:\n#   https://oeis.org/A141232 -- Overpseudoprimes to base 2: composite k such that k = A137576((k-1)/2).\n#   https://oeis.org/A140658 -- Overpseudoprimes to bases 2 and 3.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Fermat_pseudoprime\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse ntheory qw(:all);\n\nsub fermat_overpseudoprimes ($bases, $prime_limit, $callback) {\n\n    my %common_divisors;\n    my $bases_lcm = lcm(@$bases);\n\n    for (my $p = 2 ; $p <= $prime_limit ; $p = next_prime($p)) {\n        next if ($bases_lcm % $p == 0);\n        my @orders = map { znorder($_, $p) } @$bases;\n        my $sig    = join(' ', @orders);\n        push @{$common_divisors{$sig}}, $p;\n    }\n\n    my %seen;\n\n    foreach my $arr (values %common_divisors) {\n\n        my $l = scalar(@$arr);\n\n        foreach my $k (2 .. $l) {\n            forcomb {\n                my $n = vecprod(@{$arr}[@_]);\n                $callback->($n) if !$seen{$n}++;\n            } $l, $k;\n        }\n    }\n}\n\nmy @pseudoprimes;\n\nmy @bases       = (2, 3);    # generate overpseudoprime to these bases\nmy $prime_limit = 1e5;       # sieve primes up to this limit\n\nfermat_overpseudoprimes(\n    \\@bases,                 # bases\n    $prime_limit,            # prime limit\n    sub ($n) {\n        push @pseudoprimes, $n;\n    }\n);\n\n@pseudoprimes = sort { $a <=> $b } @pseudoprimes;\n\nsay join(', ', @pseudoprimes);\n\n__END__\n5173601, 13694761, 16070429, 27509653, 54029741, 66096253, 102690677, 117987841, 193949641, 206304961, 314184487, 390612221, 393611653, 717653129, 960946321, 1157839381, 1236313501, 1921309633, 2217879901, 2412172153, 2626783921, 4710862501\n"
  },
  {
    "path": "Math/fermat_overpseudoprimes_in_range.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 06 September 2022\n# https://github.com/trizen\n\n# Generate all the k-omega Fermat overpseudoprimes to a given base in a given range [a,b]. (not in sorted order)\n\n# Definition:\n#   k-omega primes are numbers n such that omega(n) = k.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://en.wikipedia.org/wiki/Prime_omega_function\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\nuse Memoize      qw(memoize);\n\nmemoize('inverse_znorder_primes');\n\nsub inverse_znorder_primes ($base, $lambda) {\n    my %seen;\n    grep { !$seen{$_}++ } factor(subint(powint($base, $lambda), 1));\n}\n\nsub iterate_over_primes ($x, $y, $base, $lambda, $callback) {\n\n    if ($lambda > 1 and $lambda <= 100) {\n        foreach my $p (inverse_znorder_primes($base, $lambda)) {\n\n            next if $p < $x;\n            last if $p > $y;\n\n            znorder($base, $p) == $lambda or next;\n\n            $callback->($p);\n        }\n        return;\n    }\n\n    if ($lambda > 1) {\n        for (my $w = $lambda * cdivint($x - 1, $lambda) ; $w <= $y ; $w += $lambda) {\n            if (is_prime($w + 1) and powmod($base, $lambda, $w + 1) == 1) {\n                $callback->($w + 1);\n            }\n        }\n        return;\n    }\n\n    for (my $p = (is_prime($x) ? $x : next_prime($x)) ; $p <= $y ; $p = next_prime($p)) {\n        $callback->($p);\n    }\n}\n\nsub fermat_overpseudoprimes_in_range ($A, $B, $k, $base, $callback) {\n\n    $A = vecmax($A, pn_primorial($k));\n\n    my $F;\n    $F = sub ($m, $lambda, $lo, $j) {\n\n        my $hi = rootint(divint($B, $m), $j);\n\n        $lo > $hi and return;\n\n        iterate_over_primes($lo, $hi, $base, $lambda, sub ($p) {\n            if ($base % $p != 0) {\n\n                for (my ($q, $v) = ($p, $m * $p) ; $v <= $B ; ($q, $v) = ($q * $p, $v * $p)) {\n\n                    my $z = znorder($base, $q);\n                    if ($lambda > 1) {\n                        $lambda == $z or last;\n                    }\n                    gcd($v, $z) == 1 or last;\n\n                    if ($j == 1) {\n                        $v >= $A or next;\n                        $k == 1 and is_prime($v) and next;\n                        ($v - 1) % $z == 0 or next;\n                        $callback->($v);\n                        next;\n                    }\n\n                    $F->($v, $z, $p + 1, $j - 1);\n                }\n            }\n        });\n    };\n\n    $F->(1, 1, 2, $k);\n    undef $F;\n}\n\n# Generate all the Fermat overpseudoprimes to base 2 in the range [1, 1325843]\n\nmy $from = 1;\nmy $upto = 1325843;\nmy $base = 2;\n\nmy @arr;\nforeach my $k (1 .. 100) {\n    last if pn_primorial($k) > $upto;\n    fermat_overpseudoprimes_in_range($from, $upto, $k, $base, sub ($n) { push @arr, $n });\n}\n\nsay join(', ', sort { $a <=> $b } @arr);\n\n__END__\n2047, 3277, 4033, 8321, 65281, 80581, 85489, 88357, 104653, 130561, 220729, 253241, 256999, 280601, 390937, 458989, 486737, 514447, 580337, 818201, 838861, 877099, 916327, 976873, 1016801, 1082401, 1145257, 1194649, 1207361, 1251949, 1252697, 1325843\n"
  },
  {
    "path": "Math/fermat_pseudoprimes_from_multiple.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 08 March 2023\n# https://github.com/trizen\n\n# Generate Fermat pseudoprimes from a given multiple, to a given base.\n\n# See also:\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\nuse 5.036;\nuse ntheory qw(:all);\n\nsub fermat_pseudoprimes_from_multiple ($base, $m, $callback) {\n\n    my $L = znorder($base, $m);\n    my $v = invmod($m, $L) // return;\n\n    for (my $p = $v ; ; $p += $L) {\n        if (is_pseudoprime($m * $p, $base)) {\n            $callback->($m * $p);\n        }\n    }\n}\n\nfermat_pseudoprimes_from_multiple(2, 341, sub ($n) { say $n });\n"
  },
  {
    "path": "Math/fermat_pseudoprimes_from_multiple_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 08 March 2023\n# https://github.com/trizen\n\n# Generate Fermat pseudoprimes from a given multiple, to a given base.\n\n# See also:\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory qw(:all);\n\nsub fermat_pseudoprimes_from_multiple ($base, $m, $callback) {\n\n    my $u = Math::GMPz::Rmpz_init();\n    my $v = Math::GMPz::Rmpz_init();\n    my $w = Math::GMPz::Rmpz_init_set_ui($base);\n\n    my $L = znorder($base, $m);\n\n    $m = Math::GMPz->new(\"$m\");\n    $L = Math::GMPz->new(\"$L\");\n\n    Math::GMPz::Rmpz_invert($v, $m, $L) || return;\n\n    for (my $p = Math::GMPz::Rmpz_init_set($v) ; ; Math::GMPz::Rmpz_add($p, $p, $L)) {\n\n        Math::GMPz::Rmpz_mul($v, $m, $p);\n        Math::GMPz::Rmpz_sub_ui($u, $v, 1);\n        Math::GMPz::Rmpz_powm($u, $w, $u, $v);\n\n        if (Math::GMPz::Rmpz_cmp_ui($u, 1) == 0) {\n            $callback->(Math::GMPz::Rmpz_init_set($v));\n        }\n    }\n}\n\nfermat_pseudoprimes_from_multiple(2, 341, sub ($n) { say $n });\n"
  },
  {
    "path": "Math/fermat_pseudoprimes_generation.pl",
    "content": "#!/usr/bin/perl\r\n\r\n# Author: Daniel \"Trizen\" Șuteu\r\n# Date: 06 May 2022\r\n# Edit: 12 November 2022\r\n# https://github.com/trizen\r\n\r\n# A new algorithm for generating Fermat pseudoprimes to multiple bases.\r\n\r\n# See also:\r\n#   https://oeis.org/A001567 -- Fermat pseudoprimes to base 2, also called Sarrus numbers or Poulet numbers.\r\n#   https://oeis.org/A050217 -- Super-Poulet numbers: Poulet numbers whose divisors d all satisfy d|2^d-2.\r\n\r\n# See also:\r\n#   https://en.wikipedia.org/wiki/Fermat_pseudoprime\r\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\r\n\r\nuse 5.020;\r\nuse warnings;\r\nuse experimental qw(signatures);\r\n\r\nuse ntheory qw(:all);\r\n\r\nsub fermat_pseudoprimes ($bases, $pm1_multiple, $prime_limit, $callback) {\r\n\r\n    my %common_divisors;\r\n    my $bases_lcm = lcm(@$bases);\r\n\r\n    for (my $p = 2 ; $p <= $prime_limit ; $p = next_prime($p)) {\r\n        next if ($bases_lcm % $p == 0);\r\n        my @orders = map { znorder($_, $p) } @$bases;\r\n        for my $d (divisors($pm1_multiple * ($p - 1))) {\r\n            if (vecall { $d % $_ == 0 } @orders) {\r\n                push @{$common_divisors{$d}}, $p;\r\n            }\r\n        }\r\n    }\r\n\r\n    my %seen;\r\n\r\n    foreach my $arr (values %common_divisors) {\r\n\r\n        my $l = scalar(@$arr);\r\n\r\n        foreach my $k (2 .. $l) {\r\n            forcomb {\r\n                my $n = vecprod(@{$arr}[@_]);\r\n                $callback->($n) if !$seen{$n}++;\r\n            } $l, $k;\r\n        }\r\n    }\r\n}\r\n\r\nmy @pseudoprimes;\r\n\r\nmy @bases        = (2, 3);    # generate Fermat pseudoprimes to these bases\r\nmy $pm1_multiple = 2 * 3;     # multiple of p-1\r\nmy $prime_limit  = 1000;      # sieve primes up to this limit\r\n\r\nfermat_pseudoprimes(\r\n    \\@bases,                  # base\r\n    $pm1_multiple,            # p-1 multiple\r\n    $prime_limit,             # prime limit\r\n    sub ($n) {\r\n        if (is_pseudoprime($n, @bases)) {\r\n            push @pseudoprimes, $n;\r\n        }\r\n    }\r\n);\r\n\r\n@pseudoprimes = sort { $a <=> $b } @pseudoprimes;\r\n\r\nsay join(', ', @pseudoprimes);\r\n\r\n__END__\r\n1729, 2701, 18721, 31621, 49141, 63973, 83333, 90751, 104653, 126217, 226801, 282133, 294409, 4670029, 10802017, 12932989, 46045117, 56052361, 83083001, 118901521, 127479097, 172947529, 216821881\r\n"
  },
  {
    "path": "Math/fermat_pseudoprimes_generation_2.pl",
    "content": "#!/usr/bin/perl\r\n\r\n# Author: Daniel \"Trizen\" Șuteu\r\n# Date: 06 May 2022\r\n# Edit: 12 November 2022\r\n# https://github.com/trizen\r\n\r\n# A new algorithm for generating Fermat pseudoprimes to multiple bases.\r\n\r\n# See also:\r\n#   https://oeis.org/A001567 -- Fermat pseudoprimes to base 2, also called Sarrus numbers or Poulet numbers.\r\n#   https://oeis.org/A050217 -- Super-Poulet numbers: Poulet numbers whose divisors d all satisfy d|2^d-2.\r\n\r\n# See also:\r\n#   https://en.wikipedia.org/wiki/Fermat_pseudoprime\r\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\r\n\r\nuse 5.020;\r\nuse warnings;\r\nuse experimental qw(signatures);\r\n\r\nuse ntheory qw(:all);\r\n\r\nsub fermat_pseudoprimes ($bases, $k_limit, $prime_limit, $callback) {\r\n\r\n    my %common_divisors;\r\n    my $bases_lcm = lcm(@$bases);\r\n\r\n    for (my $p = 2 ; $p <= $prime_limit ; $p = next_prime($p)) {\r\n        next if ($bases_lcm % $p == 0);\r\n        my @orders = map { znorder($_, $p) } @$bases;\r\n        for my $k (1 .. $k_limit) {\r\n            foreach my $o (@orders) {\r\n                push @{$common_divisors{$k * $o}}, $p;\r\n            }\r\n        }\r\n    }\r\n\r\n    my %seen;\r\n\r\n    foreach my $arr (values %common_divisors) {\r\n\r\n        my $l = scalar(@$arr);\r\n\r\n        foreach my $k (2 .. $l) {\r\n            forcomb {\r\n                my $n = vecprod(@{$arr}[@_]);\r\n                $callback->($n) if !$seen{$n}++;\r\n            } $l, $k;\r\n        }\r\n    }\r\n}\r\n\r\nmy @pseudoprimes;\r\n\r\nmy @bases       = (2, 3);    # generate Fermat pseudoprimes to these bases\r\nmy $k_limit     = 10;        # largest k multiple of the znorder(base, p)\r\nmy $prime_limit = 500;       # sieve primes up to this limit\r\n\r\nfermat_pseudoprimes(\r\n    \\@bases,                 # bases\r\n    $k_limit,                # k limit\r\n    $prime_limit,            # prime limit\r\n    sub ($n) {\r\n        if (is_pseudoprime($n, @bases)) {\r\n            push @pseudoprimes, $n;\r\n        }\r\n    }\r\n);\r\n\r\n@pseudoprimes = sort { $a <=> $b } @pseudoprimes;\r\n\r\nsay join(', ', @pseudoprimes);\r\n\r\n__END__\r\n341, 1105, 1387, 2047, 2701, 3277, 4033, 4369, 4681, 5461, 7957, 8321, 10261, 13747, 13981, 14491, 15709, 18721, 19951, 23377, 31417, 31609, 31621, 35333, 42799, 49141, 49981, 60701, 60787, 65281, 68101, 83333, 88357, 90751, 104653, 113201, 115921, 129889, 130561, 137149, 149281, 150851, 158369, 162193, 164737, 219781, 241001, 249841, 266305, 282133, 294409, 341497, 387731, 423793, 617093, 1052503, 1052929, 1104349, 1306801, 1398101, 1534541, 1549411, 1746289, 1840357, 2327041, 2899801, 2940337, 2953711, 3048841, 4072729, 4154161, 4209661, 4335241, 6236473, 8462233, 9106141, 10004681, 10802017, 11433301, 12599233, 12932989, 13216141, 15732721, 17895697, 24929281, 46045117, 50193793, 50201089, 53399449, 68033801, 74945953, 75501793, 83083001, 102134113, 108952411, 118901521, 127479097, 147868201, 172947529, 236530981, 285212689, 523842337, 555046097, 708621217, 734770681, 1007608753, 1231726981, 2201474969, 2811315361, 3664146889, 4128469381, 6812268193, 6871413901, 9077780017, 10794378673, 32733862237, 43564534561, 63450063793, 68736258049, 195931272241, 302257028449, 1688543976829, 3930678747361, 15065746744717, 27473877622369, 36610686808561, 9235302754511521, 15852427388106913\r\n"
  },
  {
    "path": "Math/fermat_pseudoprimes_generation_3.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 02 July 2022\n# Edit: 12 November 2022\n# https://github.com/trizen\n\n# A new algorithm for generating Fermat pseudoprimes to multiple bases.\n\n# See also:\n#   https://oeis.org/A001567 -- Fermat pseudoprimes to base 2, also called Sarrus numbers or Poulet numbers.\n#   https://oeis.org/A050217 -- Super-Poulet numbers: Poulet numbers whose divisors d all satisfy d|2^d-2.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Fermat_pseudoprime\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse ntheory qw(:all);\n\nsub fermat_pseudoprimes ($bases, $k_limit, $prime_limit, $callback) {\n\n    my %common_divisors;\n    my $bases_lcm = lcm(@$bases);\n\n    for (my $p = 2 ; $p <= $prime_limit ; $p = next_prime($p)) {\n        next if ($bases_lcm % $p == 0);\n        my @orders     = map { znorder($_, $p) } @$bases;\n        my $lcm_orders = lcm(@orders);\n        for my $k (1 .. $k_limit) {\n            if (is_prime($k * $lcm_orders + 1)) {\n                push @{$common_divisors{$lcm_orders}}, $k * $lcm_orders + 1;\n            }\n        }\n    }\n\n    my %seen;\n\n    foreach my $arr (values %common_divisors) {\n\n        my $l = scalar(@$arr);\n\n        foreach my $k (2 .. $l) {\n            forcomb {\n                my $n = vecprod(@{$arr}[@_]);\n                $callback->($n) if !$seen{$n}++;\n            } $l, $k;\n        }\n    }\n}\n\nmy @pseudoprimes;\n\nmy @bases       = (2, 3);    # generate Fermat pseudoprimes to these bases\nmy $k_limit     = 10;        # largest k multiple of the znorder(base, p)\nmy $prime_limit = 500;       # sieve primes up to this limit\n\nfermat_pseudoprimes(\n    \\@bases,                 # bases\n    $k_limit,                # k limit\n    $prime_limit,            # prime limit\n    sub ($n) {\n        if (is_pseudoprime($n, @bases)) {\n            push @pseudoprimes, $n;\n        }\n    }\n);\n\n@pseudoprimes = sort { $a <=> $b } @pseudoprimes;\n\nsay join(', ', @pseudoprimes);\n\n__END__\n1105, 1729, 2465, 2701, 2821, 18721, 29341, 31621, 46657, 49141, 63973, 83333, 90751, 104653, 172081, 176149, 226801, 252601, 282133, 294409, 399001, 488881, 512461, 653333, 721801, 852841, 873181, 1152271, 1373653, 1537381, 1690501, 2100901, 2944261, 3057601, 4335241, 6189121, 6309901, 10267951, 10802017, 12490201, 12932989, 17098369, 19384289, 32285041, 46045117, 50201089, 53711113, 56052361, 64377991, 68154001, 79624621, 83083001, 84350561, 118901521, 171454321, 172947529, 214852609, 216821881, 228842209, 308448649, 492559141, 650028061, 739444021, 771043201, 775368901, 947950501, 1213619761, 1269295201, 1348964401, 2140082101, 2598933481, 3787491457, 3955764121, 34453315009, 36764611129, 192739365541, 476407634761, 525473097661, 769888667161, 2570872764241, 8060437695529, 211900752829081, 2975137644706921\n"
  },
  {
    "path": "Math/fermat_pseudoprimes_in_range.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 31 August 2022\n# https://github.com/trizen\n\n# Generate all the k-omega Fermat pseudoprimes in range [a,b]. (not in sorted order)\n\n# Definition:\n#   k-omega primes are numbers n such that omega(n) = k.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://en.wikipedia.org/wiki/Prime_omega_function\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\n# PARI/GP program (slow):\n#   fermat_psp(A, B, k, base) = A=max(A, vecprod(primes(k))); (f(m, l, p, j) = my(list=List()); forprime(q=p, sqrtnint(B\\m, j), if(base%q != 0, my(v=m*q, t=q, r=nextprime(q+1)); while(v <= B, my(L=lcm(l, znorder(Mod(base, t)))); if(gcd(L, v) == 1, if(j==1, if(v>=A && if(k==1, !isprime(v), 1) && (v-1)%L == 0, listput(list, v)), if(v*r <= B, list=concat(list, f(v, L, r, j-1)))), break); v *= q; t *= q))); list); vecsort(Vec(f(1, 1, 2, k)));\n\n# PARI/GP program (fast):\n#   fermat_psp(A, B, k, base) = A=max(A, vecprod(primes(k))); (f(m, l, lo, k) = my(list=List()); my(hi=sqrtnint(B\\m, k)); if(lo > hi, return(list)); if(k==1, forstep(p=lift(1/Mod(m, l)), hi, l, if(isprimepower(p) && gcd(m*base, p) == 1, my(n=m*p); if(n >= A && (n-1) % znorder(Mod(base, p)) == 0, listput(list, n)))), forprime(p=lo, hi, base%p == 0 && next; my(z=znorder(Mod(base, p))); gcd(m,z) == 1 || next; my(q=p, v=m*p); while(v <= B, list=concat(list, f(v, lcm(l, z), p+1, k-1)); q *= p; Mod(base, q)^z == 1 || break; v *= p))); list); vecsort(Set(f(1, 1, 2, k)));\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\n\nsub fermat_pseudoprimes_in_range ($A, $B, $k, $base) {\n\n    $A = vecmax($A, pn_primorial($k));\n\n    my %seen;\n    my @list;\n\n    sub ($m, $L, $lo, $j) {\n\n        my $hi = rootint(divint($B, $m), $j);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        if ($j == 1) {\n\n            if ($L == 1) {    # optimization\n                foreach my $p (@{primes($lo, $hi)}) {\n\n                    $base % $p == 0 and next;\n\n                    for (my $v = (($m == 1) ? ($p * $p) : ($m * $p)) ; $v <= $B ; $v *= $p) {\n                        $v >= $A                       or next;\n                        powmod($base, $v - 1, $v) == 1 or last;\n                        push(@list, $v) if !$seen{$v}++;\n                    }\n                }\n                return;\n            }\n\n            my $t = invmod($m, $L);\n            $t > $hi && return;\n            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);\n\n            for (my $p = $t ; $p <= $hi ; $p += $L) {\n                if (is_prime_power($p) and gcd($m, $p) == 1 and gcd($base, $p) == 1) {\n\n                    my $v = $m * $p;\n                    $v >= $A                           or next;\n                    ($v - 1) % znorder($base, $p) == 0 or next;\n\n                    #powmod($base, $v-1, $v) == 1 or next;\n                    push(@list, $v) if !$seen{$v}++;\n                }\n            }\n\n            return;\n        }\n\n        foreach my $p (@{primes($lo, $hi)}) {\n\n            $base % $p == 0 and next;\n\n            my $z = znorder($base, $p);\n            gcd($m, $z) == 1 or next;\n\n            for (my ($q, $v) = ($p, $m * $p) ; $v <= $B ; ($q, $v) = ($q * $p, $v * $p)) {\n\n                if ($q > $p) {\n                    powmod($base, $z, $q) == 1 or last;\n                }\n\n                __SUB__->($v, lcm($L, $z), $p + 1, $j - 1);\n            }\n        }\n      }\n      ->(1, 1, 2, $k);\n\n    return sort { $a <=> $b } @list;\n}\n\n# Generate all the Fermat pseudoprimes to base 3 in range [1, 10^5]\n\nmy $from = 1;\nmy $upto = 1e5;\nmy $base = 3;\n\nmy @arr;\nforeach my $k (1 .. 100) {\n    last if pn_primorial($k) > $upto;\n    push @arr, fermat_pseudoprimes_in_range($from, $upto, $k, $base);\n}\n\nsay join(', ', sort { $a <=> $b } @arr);\n\n# Run some tests\n\nif (0) {    # true to run some tests\n    foreach my $k (1 .. 5) {\n\n        say \"Testing k = $k\";\n\n        my $lo           = pn_primorial($k);\n        my $hi           = mulint($lo, 1000);\n        my $omega_primes = omega_primes($k, $lo, $hi);\n\n        foreach my $base (2 .. 100) {\n            my @this = grep { is_pseudoprime($_, $base) and !is_prime($_) } @$omega_primes;\n            my @that = fermat_pseudoprimes_in_range($lo, $hi, $k, $base);\n            join(' ', @this) eq join(' ', @that)\n              or die \"Error for k = $k and base = $base with hi = $hi\\n(@this) != (@that)\";\n        }\n    }\n}\n\n__END__\n91, 121, 286, 671, 703, 949, 1105, 1541, 1729, 1891, 2465, 2665, 2701, 2821, 3281, 3367, 3751, 4961, 5551, 6601, 7381, 8401, 8911, 10585, 11011, 12403, 14383, 15203, 15457, 15841, 16471, 16531, 18721, 19345, 23521, 24046, 24661, 24727, 28009, 29161, 29341, 30857, 31621, 31697, 32791, 38503, 41041, 44287, 46657, 46999, 47197, 49051, 49141, 50881, 52633, 53131, 55261, 55969, 63139, 63973, 65485, 68887, 72041, 74593, 75361, 76627, 79003, 82513, 83333, 83665, 87913, 88561, 88573, 88831, 90751, 93961, 96139, 97567\n"
  },
  {
    "path": "Math/fermat_pseudoprimes_in_range_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 25 February 2023\n# https://github.com/trizen\n\n# Generate all the k-omega Fermat pseudoprimes in range [a,b]. (not in sorted order)\n\n# Definition:\n#   k-omega primes are numbers n such that omega(n) = k.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://en.wikipedia.org/wiki/Prime_omega_function\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\n# PARI/GP program (slow):\n#   fermat_psp(A, B, k, base) = A=max(A, vecprod(primes(k))); (f(m, l, p, j) = my(list=List()); forprime(q=p, sqrtnint(B\\m, j), if(base%q != 0, my(v=m*q, t=q, r=nextprime(q+1)); while(v <= B, my(L=lcm(l, znorder(Mod(base, t)))); if(gcd(L, v) == 1, if(j==1, if(v>=A && if(k==1, !isprime(v), 1) && (v-1)%L == 0, listput(list, v)), if(v*r <= B, list=concat(list, f(v, L, r, j-1)))), break); v *= q; t *= q))); list); vecsort(Vec(f(1, 1, 2, k)));\n\n# PARI/GP program (fast):\n#   fermat_psp(A, B, k, base) = A=max(A, vecprod(primes(k))); (f(m, l, lo, k) = my(list=List()); my(hi=sqrtnint(B\\m, k)); if(lo > hi, return(list)); if(k==1, forstep(p=lift(1/Mod(m, l)), hi, l, if(isprimepower(p) && gcd(m*base, p) == 1, my(n=m*p); if(n >= A && (n-1) % znorder(Mod(base, p)) == 0, listput(list, n)))), forprime(p=lo, hi, base%p == 0 && next; my(z=znorder(Mod(base, p))); gcd(m,z) == 1 || next; my(q=p, v=m*p); while(v <= B, list=concat(list, f(v, lcm(l, z), p+1, k-1)); q *= p; Mod(base, q)^z == 1 || break; v *= p))); list); vecsort(Set(f(1, 1, 2, k)));\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory 0.74 qw(:all);\n\nsub fermat_pseudoprimes_in_range ($A, $B, $k, $base) {\n\n    $A = vecmax($A, pn_primorial($k));\n\n    $A = Math::GMPz->new(\"$A\");\n    $B = Math::GMPz->new(\"$B\");\n\n    my $u = Math::GMPz::Rmpz_init();\n    my $v = Math::GMPz::Rmpz_init();\n\n    my %seen;\n    my @list;\n\n    sub ($m, $L, $lo, $j) {\n\n        Math::GMPz::Rmpz_tdiv_q($u, $B, $m);\n        Math::GMPz::Rmpz_root($u, $u, $j);\n\n        my $hi = Math::GMPz::Rmpz_get_ui($u);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        if ($j == 1) {\n\n            Math::GMPz::Rmpz_invert($v, $m, $L);\n\n            if (Math::GMPz::Rmpz_cmp_ui($v, $hi) > 0) {\n                return;\n            }\n\n            if (Math::GMPz::Rmpz_fits_ulong_p($L)) {\n                $L = Math::GMPz::Rmpz_get_ui($L);\n            }\n\n            my $t = Math::GMPz::Rmpz_get_ui($v);\n            $t > $hi && return;\n            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);\n\n            for (my $p = $t ; $p <= $hi ; $p += $L) {\n                if (is_prime_power($p) and Math::GMPz::Rmpz_gcd_ui($Math::GMPz::NULL, $m, $p) == 1 and gcd($base, $p) == 1) {\n\n                    Math::GMPz::Rmpz_mul_ui($v, $m, $p);\n\n                    if ($k == 1 and is_prime($p) and Math::GMPz::Rmpz_cmp_ui($m, 1) == 0) {\n                        ## ok\n                    }\n                    elsif (Math::GMPz::Rmpz_cmp($v, $A) >= 0) {\n                        Math::GMPz::Rmpz_sub_ui($u, $v, 1);\n                        if (Math::GMPz::Rmpz_divisible_ui_p($u, znorder($base, $p))) {\n                            push(@list, Math::GMPz::Rmpz_init_set($v)) if !$seen{Math::GMPz::Rmpz_get_str($v, 10)}++;\n                        }\n                    }\n                }\n            }\n\n            return;\n        }\n\n        my $u   = Math::GMPz::Rmpz_init();\n        my $v   = Math::GMPz::Rmpz_init();\n        my $lcm = Math::GMPz::Rmpz_init();\n\n        foreach my $p (@{primes($lo, $hi)}) {\n\n            $base % $p == 0 and next;\n\n            my $z = znorder($base, $p);\n            Math::GMPz::Rmpz_gcd_ui($Math::GMPz::NULL, $m, $z) == 1 or next;\n            Math::GMPz::Rmpz_lcm_ui($lcm, $L, $z);\n\n            Math::GMPz::Rmpz_set_ui($u, $p);\n\n            for (Math::GMPz::Rmpz_mul_ui($v, $m, $p) ; Math::GMPz::Rmpz_cmp($v, $B) <= 0 ; Math::GMPz::Rmpz_mul_ui($v, $v, $p)) {\n                __SUB__->($v, $lcm, $p + 1, $j - 1);\n                Math::GMPz::Rmpz_mul_ui($u, $u, $p);\n                powmod($base, $z, $u) == 1 or last;\n            }\n        }\n      }\n      ->(Math::GMPz->new(1), Math::GMPz->new(1), 2, $k);\n\n    return sort { $a <=> $b } @list;\n}\n\n# Generate all the Fermat pseudoprimes to base 3 in range [1, 10^5]\n\nmy $from = 1;\nmy $upto = 1e5;\nmy $base = 3;\n\nmy @arr;\nforeach my $k (1 .. 100) {\n    last if pn_primorial($k) > $upto;\n    push @arr, fermat_pseudoprimes_in_range($from, $upto, $k, $base);\n}\n\nsay join(', ', sort { $a <=> $b } @arr);\n\n# Run some tests\n\nif (0) {    # true to run some tests\n    foreach my $k (1 .. 5) {\n\n        say \"Testing k = $k\";\n\n        my $lo           = pn_primorial($k) * 4;\n        my $hi           = mulint($lo, 1000);\n        my $omega_primes = omega_primes($k, $lo, $hi);\n\n        foreach my $base (2 .. 100) {\n            my @this = grep { is_pseudoprime($_, $base) and !is_prime($_) } @$omega_primes;\n            my @that = fermat_pseudoprimes_in_range($lo, $hi, $k, $base);\n            join(' ', @this) eq join(' ', @that)\n              or die \"Error for k = $k and base = $base with hi = $hi\\n(@this) != (@that)\";\n        }\n    }\n}\n\n__END__\n91, 121, 286, 671, 703, 949, 1105, 1541, 1729, 1891, 2465, 2665, 2701, 2821, 3281, 3367, 3751, 4961, 5551, 6601, 7381, 8401, 8911, 10585, 11011, 12403, 14383, 15203, 15457, 15841, 16471, 16531, 18721, 19345, 23521, 24046, 24661, 24727, 28009, 29161, 29341, 30857, 31621, 31697, 32791, 38503, 41041, 44287, 46657, 46999, 47197, 49051, 49141, 50881, 52633, 53131, 55261, 55969, 63139, 63973, 65485, 68887, 72041, 74593, 75361, 76627, 79003, 82513, 83333, 83665, 87913, 88561, 88573, 88831, 90751, 93961, 96139, 97567\n"
  },
  {
    "path": "Math/fermat_superpseudoprimes_generation.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 28 January 2019\n# Edit: 12 November 2022\n# https://github.com/trizen\n\n# A new algorithm for generating Fermat superpseudoprimes to multiple bases.\n\n# See also:\n#   https://oeis.org/A050217 -- Super-Poulet numbers: Poulet numbers whose divisors d all satisfy d|2^d-2.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Fermat_pseudoprime\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse ntheory qw(:all);\n\nsub fermat_superpseudoprimes ($bases, $prime_limit, $callback) {\n\n    my %common_divisors;\n    my $bases_lcm = lcm(@$bases);\n\n    for (my $p = 2 ; $p <= $prime_limit ; $p = next_prime($p)) {\n        next if ($bases_lcm % $p == 0);\n        my @orders = map { znorder($_, $p) } @$bases;\n        foreach my $d (divisors($p - 1)) {\n            if (vecall { $d % $_ == 0 } @orders) {\n                push @{$common_divisors{$d}}, $p;\n            }\n        }\n    }\n\n    my %seen;\n\n    foreach my $arr (values %common_divisors) {\n\n        my $l = scalar(@$arr);\n\n        foreach my $k (2 .. $l) {\n            forcomb {\n                my $n = vecprod(@{$arr}[@_]);\n                $callback->($n) if !$seen{$n}++;\n            } $l, $k;\n        }\n    }\n}\n\nmy @bases       = (2, 3, 5);    # superpseudoprimes to these bases\nmy $prime_limit = 1e4;          # prime limit\n\nmy @pseudoprimes;\n\nfermat_superpseudoprimes(\n    \\@bases,                    # bases\n    $prime_limit,               # prime limit\n    sub ($n) {\n        push @pseudoprimes, $n;\n    }\n);\n\n@pseudoprimes = sort { $a <=> $b } @pseudoprimes;\n\nsay join(', ', @pseudoprimes);\n\n__END__\n721801, 873181, 9006401, 9863461, 10403641, 12322133, 18736381, 20234341, 21397381, 22369621, 25696133, 36307981, 42702661, 46094401, 47253781\n"
  },
  {
    "path": "Math/fibonacci_closed_form.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 29 October 2015\n# Website: https://github.com/trizen\n\n# A simple closed-form to the Fibonacci sequence\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub fib {\n    my ($n) = @_;\n\n    state $S  = sqrt(5);\n    state $T  = ((1 + $S) / 2);\n    state $U  = (2 / (1 + $S));\n    state $PI = atan2(0, -'inf');\n\n    ($T**$n - ($U**$n * cos($PI * $n))) / $S;\n}\n\nfor my $n (1 .. 20) {\n    say \"F($n) = \", fib($n);\n}\n"
  },
  {
    "path": "Math/fibonacci_closed_form_2.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 29 October 2015\n# Website: https://github.com/trizen\n\n# A very simple and fast closed-form to the Fibonacci sequence\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub fib {\n    my ($n) = @_;\n\n    state $S = sqrt(1.25) + 0.5;\n    state $T = sqrt(1.25) - 0.5;\n    state $W = $S + $T;\n\n    ($S**$n - (-$T)**($n)) / $W;\n}\n\nfor my $n (1 .. 20) {\n    say \"F($n) = \", fib($n);\n}\n"
  },
  {
    "path": "Math/fibonacci_encoding.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 22 January 2018\n# https://github.com/trizen\n\n# Encode positive integers in binary format, using the Fibonacci numbers.\n\n# Example:\n#   30 = 10100010 = 1×21 + 0×13 + 1×8 + 0×5 + 0×3 + 0×2 + 1×1 + 0×1\n\n# See also:\n#   https://projecteuler.net/problem=473\n#   https://en.wikipedia.org/wiki/Fibonacci_coding\n#   https://en.wikipedia.org/wiki/Zeckendorf%27s_theorem\n#   https://en.wikipedia.org/wiki/Golden_ratio_base\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(lucasu);\nuse experimental qw(signatures);\n\nsub fib ($n) {\n    lucasu(1, -1, $n);\n}\n\nsub fibonacci_encoding ($n) {\n    return '0' if ($n == 0);\n\n    my $phi = sqrt(1.25) + 0.5;\n    my $log = int((log($n) + log(5)/2) / log($phi));\n\n    my ($f1, $f2) = (fib($log), fib($log - 1));\n\n    if ($f1 + $f2 <= $n) {\n        ($f1, $f2) = ($f1 + $f2, $f1);\n    }\n\n    my $enc = '';\n\n    while ($f1 > 0) {\n\n        if ($n >= $f1) {\n            $n -= $f1;\n            $enc .= '1';\n        }\n        else {\n            $enc .= '0';\n        }\n\n        ($f1, $f2) = ($f2, $f1 - $f2);\n    }\n\n    return $enc;\n}\n\nsub fibonacci_decoding($enc) {\n\n    my $len = length($enc);\n    my ($f1, $f2) = (fib($len), fib($len - 1));\n\n    my $dec = 0;\n\n    foreach my $i (0 .. $len - 1) {\n        my $bit = substr($enc, $i, 1);\n        $dec += $f1 if $bit;\n        ($f1, $f2) = ($f2, $f1 - $f2);\n    }\n\n    return $dec;\n}\n\nsay fibonacci_encoding(30);            #=> 10100010\nsay fibonacci_decoding('10100010');    #=> 30\n\nsay fibonacci_decoding(fibonacci_encoding(144));        #=> 144\nsay fibonacci_decoding(fibonacci_encoding(144 - 1));    #=> 143\nsay fibonacci_decoding(fibonacci_encoding(144 + 1));    #=> 145\n\n# Transparent support for arbitrary large integers\nsay fibonacci_decoding(fibonacci_encoding('81923489126412312421758612841248123'));\n\n# Verify the encoding/decoding algorithm\nforeach my $n (0 .. 10000) {\n    if (fibonacci_decoding(fibonacci_encoding($n)) != $n) {\n        die \"Error for $n\";\n    }\n}\n"
  },
  {
    "path": "Math/fibonacci_factorization_method.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 09 September 2018\n# https://github.com/trizen\n\n# A new integer factorization method, using the Fibonacci numbers.\n\n# It uses the smallest divisor `d` of `p - legendre(p, 5)`, for which `Fibonacci(d) = 0 (mod p)`.\n\n# By selecting a small bound B, we compute `k = lcm(1..B)`, hoping that `k` is a\n# multiple of `d`, then `gcd(Fibonacci(k) (mod n), n)` in a non-trivial factor of `n`.\n\n# This method is similar in flavor to Pollard's p-1 and Williams's p+1 methods.\n\nuse 5.020;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Math::AnyNum qw(:overload gcd ilog2 is_prime);\nuse Math::Prime::Util::GMP qw(consecutive_integer_lcm random_prime lucas_sequence);\n\nsub fibonacci_factorization ($n, $B = 10000) {\n\n    my $k = consecutive_integer_lcm($B);            # lcm(1..B)\n    my $F = (lucas_sequence($n, 1, -1, $k))[0];     # Fibonacci(k) (mod n)\n\n    return gcd($F, $n);\n}\n\nsay fibonacci_factorization(257221 * 470783,              700);     #=> 470783           (p+1 is  700-smooth)\nsay fibonacci_factorization(333732865481 * 1632480277613, 3000);    #=> 333732865481     (p-1 is 3000-smooth)\n\n# Example of a larger number that can be factorized fast with this method\nsay fibonacci_factorization(203544696384073367670016326770637347800169508950125910682353, 19);    #=> 5741461760879844361\n\nforeach my $k (1 .. 50) {\n\n    my $n = Math::AnyNum->new(random_prime(1 << $k)) * random_prime(1 << $k);\n    my $p = fibonacci_factorization($n, 2 * ilog2($n)**2);\n\n    if (is_prime($p)) {\n        say \"$n = $p * \", $n / $p;\n    }\n}\n"
  },
  {
    "path": "Math/fibonacci_k-th_order.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 20 April 2018\n# https://github.com/trizen\n\n# Compute the k-th order Fibonacci numbers.\n\n# See also:\n#   https://oeis.org/A000045    (2-nd order: Fibonacci numbers)\n#   https://oeis.org/A000073    (3-rd order: Tribonacci numbers)\n#   https://oeis.org/A000078    (4-th order: Tetranacci numbers)\n#   https://oeis.org/A001591    (5-th order: Pentanacci numbers)\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(vecsum);\nuse experimental qw(signatures);\n\nsub kth_order_fibonacci ($n, $k = 2) {\n\n    my @A = ((0) x ($k - 1), 1);\n\n    for (1 .. $n) {\n        @A = (@A[1 .. $k - 1], vecsum(@A[0 .. $k - 1]));\n    }\n\n    return $A[-1];\n}\n\nfor my $n (0 .. 20) {\n    say kth_order_fibonacci($n, 5);\n}\n"
  },
  {
    "path": "Math/fibonacci_k-th_order_efficient_algorithm.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 24 January 2019\n# https://github.com/trizen\n\n# Generalized efficient formula for computing the k-th order Fibonacci numbers, using exponentiation by squaring.\n\n# OEIS sequences:\n#   https://oeis.org/A000045    (2-nd order: Fibonacci numbers)\n#   https://oeis.org/A000073    (3-rd order: Tribonacci numbers)\n#   https://oeis.org/A000078    (4-th order: Tetranacci numbers)\n#   https://oeis.org/A001591    (5-th order: Pentanacci numbers)\n\n# See also:\n#   https://en.wikipedia.org/wiki/Generalizations_of_Fibonacci_numbers\n#   https://en.wikipedia.org/wiki/Exponentiation_by_squaring\n\n# Example of Fibonacci matrices for k=2..4:\n#\n#   A_2 = Matrix(\n#           [0, 1],\n#           [1, 1]\n#         )\n#\n#   A_3 = Matrix(\n#           [0, 1, 0],\n#           [0, 0, 1],\n#           [1, 1, 1]\n#         )\n#\n#   A_4 = Matrix(\n#           [0, 1, 0, 0],\n#           [0, 0, 1, 0],\n#           [0, 0, 0, 1],\n#           [1, 1, 1, 1]\n#         )\n\n# Let R = (A_k)^n.\n# The n-th k-th order Fibonacci number is the last term in the first row of R.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::MatrixLUP;\nuse experimental qw(signatures);\n\nsub fibonacci_matrix($k) {\n    Math::MatrixLUP->build(\n        $k, $k,\n        sub ($i, $j) {\n            (($i == $k - 1) || ($i == $j - 1)) ? 1 : 0;\n        }\n    );\n}\n\nsub modular_fibonacci_kth_order ($n, $k, $m) {\n    my $A = fibonacci_matrix($k);\n    ($A->powmod($n, $m))->[0][-1];\n}\n\nsub fibonacci_kth_order ($n, $k = 2) {\n    my $A = fibonacci_matrix($k);\n    ($A**$n)->[0][-1];\n}\n\nforeach my $k (2 .. 6) {\n    say(\"Fibonacci of k=$k order: \", join(', ', map { fibonacci_kth_order($_, $k) } 0 .. 14 + $k));\n}\n\nsay '';\n\nforeach my $k (2 .. 6) {\n    say(\"Last n digits of 10^n $k-order Fibonacci numbers: \",\n        join(', ', map { modular_fibonacci_kth_order(10**$_, $k, 10**$_) } 0 .. 9));\n}\n\n__END__\nFibonacci of k=2 order: 0, 1, 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, 144, 233, 377, 610, 987\nFibonacci of k=3 order: 0, 0, 1, 1, 2, 4, 7, 13, 24, 44, 81, 149, 274, 504, 927, 1705, 3136, 5768\nFibonacci of k=4 order: 0, 0, 0, 1, 1, 2, 4, 8, 15, 29, 56, 108, 208, 401, 773, 1490, 2872, 5536, 10671\nFibonacci of k=5 order: 0, 0, 0, 0, 1, 1, 2, 4, 8, 16, 31, 61, 120, 236, 464, 912, 1793, 3525, 6930, 13624\nFibonacci of k=6 order: 0, 0, 0, 0, 0, 1, 1, 2, 4, 8, 16, 32, 63, 125, 248, 492, 976, 1936, 3840, 7617, 15109\n\nLast n digits of 10^n 2-order Fibonacci numbers: 0, 5, 75, 875, 6875, 46875, 546875, 546875, 60546875, 560546875\nLast n digits of 10^n 3-order Fibonacci numbers: 0, 1, 58, 384, 1984, 62976, 865536, 2429440, 86712832, 941792256\nLast n digits of 10^n 4-order Fibonacci numbers: 0, 6, 96, 160, 1792, 92544, 348928, 6868608, 41256704, 824732160\nLast n digits of 10^n 5-order Fibonacci numbers: 0, 1, 33, 385, 1025, 69921, 360833, 4117505, 34469121, 304605953\nLast n digits of 10^n 6-order Fibonacci numbers: 0, 6, 4, 925, 3376, 93151, 642996, 3541264, 38339728, 425978989\n"
  },
  {
    "path": "Math/fibonacci_k-th_order_fast.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 25 April 2018\n# https://github.com/trizen\n\n# Efficient algorithm for computing the k-th order Fibonacci numbers.\n\n# See also:\n#   https://oeis.org/A000045    (2-nd order: Fibonacci numbers)\n#   https://oeis.org/A000073    (3-rd order: Tribonacci numbers)\n#   https://oeis.org/A000078    (4-th order: Tetranacci numbers)\n#   https://oeis.org/A001591    (5-th order: Pentanacci numbers)\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\nuse experimental qw(signatures);\n\nsub kth_order_fibonacci ($n, $k = 2) {\n\n    # Algorithm due to M. F. Hasler\n    # See: https://oeis.org/A302990\n\n    if ($n < $k - 1) {\n        return 0;\n    }\n\n    my @f = map {\n        $_ < $k\n          ? do {\n            my $z = Math::GMPz::Rmpz_init();\n            Math::GMPz::Rmpz_setbit($z, $_);\n            $z;\n          }\n          : Math::GMPz::Rmpz_init_set_ui(1)\n    } 1 .. ($k + 1);\n\n    my $t = Math::GMPz::Rmpz_init();\n\n    foreach my $i (2 * ++$k - 2 .. $n) {\n        Math::GMPz::Rmpz_mul_2exp($t, $f[($i - 1) % $k], 1);\n        Math::GMPz::Rmpz_sub($f[$i % $k], $t, $f[$i % $k]);\n    }\n\n    return $f[$n % $k];\n}\n\nsay \"Tribonacci: \", join(' ', map { kth_order_fibonacci($_, 3) } 0 .. 15);\nsay \"Tetranacci: \", join(' ', map { kth_order_fibonacci($_, 4) } 0 .. 15);\nsay \"Pentanacci: \", join(' ', map { kth_order_fibonacci($_, 5) } 0 .. 15);\n"
  },
  {
    "path": "Math/fibonacci_k-th_order_odd_primes_indices.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu and M. F. Hasler\n# Date: 20 April 2018\n# Edit: 23 April 2018\n# https://github.com/trizen\n\n# Find the first index of the odd prime number in the nth-order Fibonacci sequence.\n\n# See also:\n#   https://oeis.org/A302990\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\n\nmy $ONE = Math::GMPz->new(1);\n\nuse ntheory qw(is_prob_prime);\nuse experimental qw(signatures);\n\nsub nth_order_prime_fibonacci_index ($n = 2, $min = 0) {\n\n    # Algorithm after M. F. Hasler from https://oeis.org/A302990\n    my @a = map { $_ < $n ? ($ONE << $_) : $ONE } 1 .. ($n + 1);\n\n    for (my $i = 2 * ($n += 1) - 2 ; ; ++$i) {\n\n        my $t  = $i % $n;\n        $a[$t] = ($a[$t-1] << 1) - $a[$t];\n\n        if ($i >= $min and Math::GMPz::Rmpz_odd_p($a[$t])) {\n            #say \"Testing: $i\";\n\n            if (is_prob_prime($a[$t])) {\n                #say \"\\nFound: $t -> $i\\n\";\n                return $i;\n            }\n        }\n    }\n}\n\n# a(33) = 94246\n# a(36) = ?\n# a(37) = 758\n# a(38) = ?\n# a(39) = ?\n\n# a(36)  > 170050       (M. F. Hasler)\n# a(38)  > 40092\n# a(41)  > 142000       (M. F. Hasler)\n# a(100) > 48076\n\n# Example for computing the terms a(2)-a(26):\nsay join \", \", map{ nth_order_prime_fibonacci_index($_) } 2..26;\n\n# Searching for a(36)\n# say nth_order_prime_fibonacci_index(36, 170051);\n"
  },
  {
    "path": "Math/fibonacci_number_fast.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 19 June 2018\n# https://github.com/trizen\n\n# An efficient algorithm for computing the nth-Fibonacci number.\n\n# See also:\n#   https://github.com/trizen/perl-scripts/blob/master/Math/modular_fibonacci_cassini.pl\n#   https://github.com/trizen/perl-scripts/blob/master/Math/modular_fibonacci_cassini_fast.pl\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload ilog2 getbit);\n\nsub fibonacci_number($n) {\n\n    my ($f, $g) = (0, 1);\n    my ($a, $b) = (0, 1);\n\n    foreach my $k (0 .. ilog2($n)||0) {\n        ($f, $g) = ($f*$a + $g*$b, $f*$b + $g*($a+$b)) if getbit($n, $k);\n        ($a, $b) = ($a*$a + $b*$b, $a*$b + $b*($a+$b));\n    }\n\n    return $f;\n}\n\nsay fibonacci_number(100);                              #=> 354224848179261915075\nsay join(' ', map { fibonacci_number($_) } 0 .. 15);    #=> 0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610\n"
  },
  {
    "path": "Math/fibonacci_polynomials_closed_form.pl",
    "content": "#!/usr/bin/perl\n\n# Closed-form expression for Fibonacci polynomials:\n#    Sum_{k=0..n} (fibonacci(k) * x^k)\n\n# Formulas generated by Wolfram|Alpha.\n\n# See also:\n#   https://projecteuler.net/problem=435\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload);\n\nsub F1 ($n, $x) {\n    (2**(-$n-1)*$x*(2*sqrt(5)*(1+sqrt(5))**$n*$x**($n+1)+(5+sqrt(5))*(1+sqrt(5))**$n*$x**$n-2*sqrt(5)*$x*($x-sqrt(5)*$x)**$n-sqrt(5)*($x-sqrt(5)*$x)**$n+5*($x-sqrt(5)*$x)**$n-5*2**($n+1)))/(5*($x**2+$x-1));\n}\n\nsub F2 ($n, $x) {\n    -(2**(2-$n)*(1+sqrt(5))**(-1-$n)*$x*((2*(1+sqrt(5)))**$n*(5+3*sqrt(5))-((-4)**$n*(1+sqrt(5))+2*(1+sqrt(5))**(2*$n)*(2+sqrt(5)))*$x**$n+(3+sqrt(5))*((-4)**$n-(1+sqrt(5))**(2*$n))*$x**(1+$n)))/(sqrt(5)*(1+sqrt(5)+2*$x)*(-2+$x+sqrt(5)*$x));\n}\n\nsay F1(7, 11);      #=> 268357683\nsay F2(7, 11);      #=> =//=\n"
  },
  {
    "path": "Math/fibonacci_pseudoprimes_generation.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 22 September 2018\n# https://github.com/trizen\n\n# A new algorithm for generating Fibonacci pseudoprimes.\n\n# OEIS:\n#   https://oeis.org/A081264 -- Odd Fibonacci pseudoprimes.\n#   https://oeis.org/A212424 -- Frobenius pseudoprimes with respect to Fibonacci polynomial x^2 - x - 1.\n\n# See also:\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n#   https://trizenx.blogspot.com/2018/08/investigating-fibonacci-numbers-modulo-m.html\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse Math::AnyNum qw(prod powmod);\nuse ntheory qw(forcomb forprimes kronecker divisors lucas_sequence);\n\nsub fibonacci_pseudoprimes ($limit, $callback) {\n\n    my %common_divisors;\n\n    forprimes {\n        my $p = $_;\n        foreach my $d (divisors($p - kronecker($p, 5))) {\n            if ((lucas_sequence($p, 1, -1, $d))[0] == 0) {\n                push @{$common_divisors{$d}}, $p;\n            }\n        }\n    } 3, $limit;\n\n    my %seen;\n\n    foreach my $arr (values %common_divisors) {\n\n        my $l = $#{$arr} + 1;\n\n        foreach my $k (2 .. $l) {\n            forcomb {\n                my $n = prod(@{$arr}[@_]);\n                $callback->($n, @{$arr}[@_]) if !$seen{$n}++;\n            } $l, $k;\n        }\n    }\n}\n\nsub is_fibonacci_pseudoprime($n) {\n    (lucas_sequence($n, 1, -1, $n - kronecker($n, 5)))[0] == 0;\n}\n\nmy @pseudoprimes;\n\nfibonacci_pseudoprimes(\n    10_000,\n    sub ($n, @f) {\n\n        is_fibonacci_pseudoprime($n)\n            or die \"Not a Fibonacci pseudoprime: $n\";\n\n        push @pseudoprimes, $n;\n\n        if (kronecker($n, 5) == -1) {\n            if (powmod(2, $n - 1, $n) == 1) {\n                die \"Found a special pseudoprime: $n = prod(@f)\";\n            }\n        }\n    }\n);\n\n@pseudoprimes = sort { $a <=> $b } @pseudoprimes;\n\nsay join(', ', @pseudoprimes);\n\n__END__\n323, 377, 1891, 3827, 4181, 5777, 8149, 10877, 11663, 13201, 15251, 17711, 18407, 19043, 23407, 25877, 27323, 34943, 39203, 40501, 51841, 51983, 53663, 60377, 64079, 64681, 67861, 68251, 75077, 78409, 86063, 88601, 88831, 90061, 94667, 96049, 97921, 100127, 113573, 115231, 118441, 121103, 121393, 145351, 146611, 153781, 161027, 162133, 182513, 191351, 195227, 197209, 200147, 218791, 219781, 231703, 250277, 254321, 272611, 294527, 302101, 303101, 306287, 330929, 345913, 381923, 429263, 430127, 433621, 438751, 453151, 454607, 456301, 500207, 507527, 520801, 530611, 548627, 556421, 569087, 572839, 600767, 607561, 629911, 635627, 636641, 636707, 638189, 642001, 685583, 697883, 721801, 722261, 736163, 741751, 753251, 753377, 775207, 828827, 851927, 853469, 873181, 948433, 954271, 983903, 999941, 1010651, 1026241, 1033997, 1056437, 1061341, 1081649, 1084201, 1106327, 1106561, 1174889, 1197377, 1203401, 1207361, 1256293, 1283311, 1300207, 1314631, 1346269, 1363861, 1388903, 1392169, 1418821, 1457777, 1589531, 1626041, 1633283, 1657847, 1690501, 1697183, 1724213, 1735841, 1803601, 1950497, 1963501, 1967363, 1970299, 2011969, 2039183, 2055377, 2071523, 2122223, 2137277, 2140921, 2159389, 2187841, 2214143, 2221811, 2253751, 2263127, 2290709, 2362081, 2435423, 2465101, 2530007, 2585663, 2586229, 2662277, 2741311, 2757241, 2782223, 2850077, 2872321, 2883203, 3140047, 3166057, 3175883, 3188011, 3196943, 3277231, 3281749, 3289301, 3338221, 3399527, 3452147, 3459761, 3470921, 3526883, 3568661, 3604201, 3645991, 3663871, 3685207, 3768451, 3774377, 3850907, 3939167, 3942271, 3992003, 3996991, 4023823, 4109363, 4112783, 4119301, 4187341, 4226777, 4229551, 4359743, 4395467, 4403027, 4415251, 4643627, 4672403, 4686391, 4713361, 4766327, 4828277, 4868641, 4870847, 5008643, 5016527, 5102959, 5143823, 5208377, 5308181, 5328181, 5447881, 5536127, 5652191, 5702887, 5734013, 5737577, 5942627, 5998463, 6011777, 6192721, 6245147, 6359021, 6368689, 6374111, 6380207, 6469789, 6471931, 6494801, 6544561, 6571601, 6580549, 6671611, 6735007, 6755251, 6759751, 6884131, 6976201, 6986251, 6989569, 7064963, 7067171, 7174081, 7192007, 7225343, 7353917, 7369601, 7371079, 7398151, 7405201, 7451153, 7473407, 7493953, 7738363, 7879681, 7950077, 7961801, 8086231, 8259761, 8390933, 8418827, 8502551, 8518127, 8655511, 8668607, 8834641, 8935877, 9031651, 9080191, 9191327, 9351647, 9353761, 9401893, 9433883, 9476741, 9493579, 9713027, 9793313, 9808651, 9811891, 9863461, 9922337, 10036223, 10339877, 10386241, 10403641, 10505701, 10604431, 10614563, 10679131, 10837601, 11205277, 11388007, 11460077, 11826383, 12007001, 12027023, 12040447, 12049409, 12119101, 12387799, 12446783, 12537527, 12572983, 12659363, 12958081, 12975691, 13012651, 13079221, 13158713, 13186637, 13277423, 13295281, 13404751, 13455077, 13464467, 13870001, 14197823, 14575091, 14792971, 14892541, 15309737, 15350723, 15371201, 15576571, 15786647, 15811613, 16060277, 16173827, 16253551, 16403407, 16485493, 16724927, 17040383, 17068127, 17288963, 17551883, 17791523, 18673201, 18736381, 18818243, 18888379, 19752767, 20018627, 20234341, 20261251, 20410207, 20412323, 20551301, 20621567, 20623969, 20684303, 20754049, 21215801, 21511043, 21574279, 21692189, 21711583, 21783961, 21843007, 21988961, 22187791, 22361327, 22591301, 22634569, 22660007, 22669501, 22924943, 22994371, 23307377, 23561399, 23581277, 24151381, 24157817, 24493061, 24550241, 24681023, 24781423, 24930881, 24974777, 25183621, 25532501, 25707841, 25957231, 26118377, 26992877, 27012001, 27085451, 28785077, 28985207, 29242127, 29354723, 29395277, 30008483, 31504141, 32012963, 32060027, 32683201, 32815361, 32817151, 33385283, 33796531, 33999491, 34175777, 34433423, 35798491, 36307981, 36342653, 37123421, 37510019, 38415203, 38850173, 39088169, 39139127, 39850127, 40208027, 40747877, 40928627, 42149971, 42389027, 42399451, 42702661, 43687877, 44166407, 45768251, 46094401, 46112921, 46114921, 46344377, 46621583, 46672291, 46777807, 47253781, 47728501, 48274703, 49019851, 49476377, 49863661, 50808383, 50823151, 51803761, 51876301, 53406863, 53655551, 55621763, 55681841, 55830251, 56070143, 56972303, 57113717, 60186563, 62062883, 65415743, 70358543, 72897443, 73925603, 74442383, 75821503, 78110243, 78478943, 79624621, 83983073, 85423337, 89075843, 93663683, 95413823, 97180163, 118901521, 121543501, 142030331, 224056801, 241924073, 246858841, 247679023, 388148903, 425399633, 429718411, 485989067, 732773791, 841980289, 957600541, 1312939321, 1706314037, 1932942527, 1952566309, 2166124801, 2166249691, 2244734413, 3173584391, 3383791321, 3406661927, 3585571907, 3807749821, 3938826767, 4250132963, 4293281521, 4369513223, 4598585921, 4610083201, 5073193501, 5374978561, 5410184641, 5802147391, 6317014703, 6390421291, 6486191209, 6666202787, 7917170801, 8631989203, 8645365081, 9340061821, 9506984911, 10193270401, 10490001721, 10521133201, 10908573077, 11384387281, 11851534697, 12182626763, 12525647327, 14678225269, 15216199501, 19770082847, 19941055289, 20286012751, 21380110489, 21936153271, 25933744367, 30550875623, 32376761983, 32855188591, 34933139161, 35646833933, 41898691223, 44912519441, 47075139721, 48306406891, 48568811171, 51068212561, 51489442351, 52396612381, 60804014251, 70504918721, 71432012629, 73817444191, 80952788071, 84654526967, 192813486181, 309385004989, 314101265081, 384655562873, 845776459637, 4211881766333, 4254641987311, 4382720043971, 45663814702501, 55216945762217, 79511946282173, 295569290441221, 838164471500267\n"
  },
  {
    "path": "Math/find_least_common_denominator.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 10 May 2016\n# Website: https://github.com/trizen\n\n# Find the least common denominator for a list of fractions and map each\n# numerator to the ratio of the common denominator over the original denominator.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(lcm);\nuse Math::AnyNum qw(:overload);\n\nmy @fractions = (\n      19 / 6,\n     160 / 51,\n    1744 / 555,\n     644 / 205,\n    2529 / 805,\n);\n\nmy $common_den = lcm(map { $_->denominator } @fractions);\n\nmy @numerators = map {\n    $_->numerator * $common_den / $_->denominator\n} @fractions;\n\nsay \"=> Numerators:\";\nforeach my $n (@numerators) { say \"\\t$n\" }\n\nsay \"\\n=> Common denominator: $common_den\";\n"
  },
  {
    "path": "Math/floor_and_ceil_functions_fourier_series.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 19 November 2017\n# https://github.com/trizen\n\n# Floor and ceil functions, implemented using closed-form Fourier series.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Floor_and_ceiling_functions#Continuity_and_series_expansions\n\nuse 5.020;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload tau pi e log2 ilog2);\n\nsub floor ($x) {\n    $x + (i * (log(1 - exp(tau * i * $x)) - log(exp(-tau * i * $x) * (-1 + exp(tau * i * $x))))) / tau - 1/2;\n}\n\nsub ceil ($x) {\n    $x + (i * (log(1 - exp(tau * i * $x)) - log(exp(-tau * i * $x) * (-1 + exp(tau * i * $x))))) / tau + 1/2;\n}\n\nsay floor(8.95);    #=> 8\nsay ceil(8.95);     #=> 9\n\nsay floor(18.3);    #=> 18\nsay ceil(18.3);     #=> 19\n\n#\n## Test with Vacca's formula for Euler-Mascheroni constant\n#\n\n# See also:\n#   https://en.wikipedia.org/wiki/Euler%E2%80%93Mascheroni_constant#Series_expansions\n\nmy $sum0 = 0.0;\nmy $sum1 = 0.0;\nmy $sum2 = 0.0;\nmy $sum3 = 0.0;\n\nforeach my $n (2 .. 10000) {\n    $sum0 += (-1)**$n * ilog2($n) / $n;\n    $sum1 += (-1)**$n * floor(log2($n + 1/2)) / $n;\n    $sum2 += (-1)**$n * (tau * log($n + 1/2) - log(2) * (i*log(1 - (2*$n+1)**(-(tau*i) / (log(2)))) - i*log(1 - (2*$n+1)**((tau*i) / (log(2)))) + pi)) / (pi * log(4) * $n);\n    $sum3 += (-1)**$n * (tau * log($n) - log(2) * (i*log(1 - $n**(-(tau*i) / (log(2)))) - i*log(1 - $n**((tau*i) / (log(2)))) + pi)) / (pi * log(4) * $n);\n}\n\nsay $sum0;    #=> 0.577804596003519592136242513827950669265457764297\nsay $sum1;    #=> 0.577804596003519592136242513827950669265457764297-2.10816560532506695800025812910971220454909391515e-60i\nsay $sum2;    #=> 0.577804596003519592136242513827950669265457764297\nsay $sum3;    #=> 0.577804596003520848567920428074451834158559906352\n"
  },
  {
    "path": "Math/flt_factorization_method.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 02 August 2020\n# Edit: 02 March 2026\n# https://github.com/trizen\n\n# A new factorization method for numbers that have all prime factors close to each other.\n\n# Inpsired by Fermat's Little Theorem (FLT).\n\nuse 5.014;\nuse warnings;\nuse Math::GMPz;\n\nuse ntheory qw(:all);\nuse POSIX   qw(ULONG_MAX);\n\nsub flt_factor {\n    my ($n, $base, $reps) = @_;\n\n    # base: a native integer <= sqrt(ULONG_MAX)\n    # reps: how many tries before giving up\n\n    if (ref($n) ne 'Math::GMPz') {\n        $n = Math::GMPz->new(\"$n\");\n    }\n\n    $base = 2   if (!defined($base) or $base < 2);\n    $reps = 1e6 if (!defined($reps));\n\n    my $z     = Math::GMPz::Rmpz_init();\n    my $t     = Math::GMPz::Rmpz_init_set_ui($base);\n    my $g     = Math::GMPz::Rmpz_init();\n    my $accum = Math::GMPz::Rmpz_init_set_ui(1);\n\n    Math::GMPz::Rmpz_powm($z, $t, $n, $n);\n\n    Math::GMPz::Rmpz_sub($g, $z, $t);\n    Math::GMPz::Rmpz_gcd($g, $g, $n);\n    if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0 && Math::GMPz::Rmpz_cmp($g, $n) < 0) {\n        my $x = Math::GMPz::Rmpz_init();\n        Math::GMPz::Rmpz_divexact($x, $n, $g);\n        return sort { Math::GMPz::Rmpz_cmp($a, $b) } ($x, $g);\n    }\n\n    # Cannot factor Fermat pseudoprimes\n    if (Math::GMPz::Rmpz_cmp_ui($z, $base) == 0) {\n        return ($n);\n    }\n\n    my $multiplier = $base * $base;\n\n    if ($multiplier > ULONG_MAX) {    # base is too large\n        return ($n);\n    }\n\n    for (my $j = 1 ; $j <= $reps ; $j++) {\n        Math::GMPz::Rmpz_mul_ui($t, $t, $multiplier);\n        Math::GMPz::Rmpz_mod($t, $t, $n);\n\n        Math::GMPz::Rmpz_sub($g, $z, $t);\n\n        # Multiply into accumulator instead of GCD every time\n        Math::GMPz::Rmpz_mul($accum, $accum, $g);\n        Math::GMPz::Rmpz_mod($accum, $accum, $n);\n\n        # Only run the expensive GCD operation every 50 iterations\n        if ($j % 50 == 0) {\n            Math::GMPz::Rmpz_gcd($g, $accum, $n);\n\n            if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {\n                if (Math::GMPz::Rmpz_cmp($g, $n) == 0) {\n                    return $n;    # Collision, would need backtracking here\n                }\n                my $x = Math::GMPz::Rmpz_init();\n                Math::GMPz::Rmpz_divexact($x, $n, $g);\n                return sort { Math::GMPz::Rmpz_cmp($a, $b) } ($x, $g);\n            }\n\n            # Reset accumulator\n            Math::GMPz::Rmpz_set_ui($accum, 1);\n        }\n    }\n\n    return $n;\n}\n\nmy $p = random_ndigit_prime(30);\n\nsay join ' * ', flt_factor(\"173315617708997561998574166143524347111328490824959334367069087\");\nsay join ' * ', flt_factor(\"2425361208749736840354501506901183117777758034612345610725789878400467\");\n\nsay join ' * ', flt_factor(vecprod($p, next_prime($p),      next_prime(next_prime($p))));\nsay join ' * ', flt_factor(vecprod($p, next_prime(13 * $p), next_prime(123 * $p)));\nsay join ' * ', flt_factor(vecprod($p, next_prime($p),      next_prime(next_prime($p)), powint(2, 128) + 1));\n"
  },
  {
    "path": "Math/fraction_approximation.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 14 July 2017\n# https://github.com/trizen\n\n# Simple and efficient algorithm for finding the smallest fraction\n# approximation to any given real number, using continued fractions.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Test::More;\nplan tests => 11;\n\nuse Math::AnyNum qw(:overload float real round);\n\nsub num2cfrac ($callback, $n) {\n    while (1) {\n        my $m = int(round($n));\n        $callback->($m) && return 1;\n        $n = 1 / (($n - $m) || last);\n    }\n}\n\nsub cfrac2num (@f) {\n    sub ($i) {\n        $i < $#f ? ($f[$i] + 1 / __SUB__->($i + 1)) : $f[$i];\n    }->(0);\n}\n\nsub fraction_approximation($dec) {\n\n    $dec = real(float($dec));\n\n    my ($rat, @nums);\n    my $str = \"$dec\";\n\n    num2cfrac(\n        sub ($n) {\n            push @nums, $n;\n            $rat = cfrac2num(@nums);\n            index($rat->as_dec, $str) == 0;\n        }, $dec\n    );\n\n    return $rat;\n}\n\nis(fraction_approximation('0.6180339887'),    '260497/421493');\nis(fraction_approximation('1.008155930329'),  '7293/7234');\nis(fraction_approximation('1.0019891835756'), '524875/523833');\nis(fraction_approximation('529.12424242424'), '174611/330');\n\nis(fraction_approximation((1 / 6)->as_dec),  '1/6');\nis(fraction_approximation((13 / 6)->as_dec), '13/6');\nis(fraction_approximation((6 / 13)->as_dec), '6/13');\n\nis(fraction_approximation('5.010893246187'), '2300/459');\nis(fraction_approximation('5.054466230936'), '2320/459');\n\nis(fraction_approximation(5.0108932461873638344226579520697167755991285403), '2300/459');\nis(fraction_approximation(5.0544662309368191721132897603485838779956427015), '2320/459');\n"
  },
  {
    "path": "Math/fraction_to_decimal_expansion.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 14 November 2017\n# https://github.com/trizen\n\n# Conversion of a fraction to a decimal-expansion with an arbitrary number of decimals, using Math::AnyNum.\n\nuse 5.020;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(bernfrac ilog10);\n\nsub frac2dec ($x, $p = 32) {\n    my $size = ilog10(abs($x)) + 1;\n    $x->as_dec($size + $p);\n}\n\nmy $n = bernfrac(60);\n\nsay frac2dec($n);        #=> -21399949257225333665810744765191097.39267415116172387457421830769266\nsay frac2dec($n, 48);    #=> -21399949257225333665810744765191097.392674151161723874574218307692659887265915822235\n"
  },
  {
    "path": "Math/fractional_pi.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 10 May 2016\n# Website: https://github.com/trizen\n\n# Calculate PI by computing the numerator and the denominator fraction that approaches the value of PI.\n# It's based on the continued fraction: n^2 / (2n+1)\n\n# See: https://oeis.org/A054766\n#      https://oeis.org/A054765\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Memoize qw(memoize);\nuse Math::AnyNum qw(:overload as_dec);\n\nno warnings 'recursion';\n\nmemoize('pi_nu');\nmemoize('pi_de');\n\nsub pi_nu {\n    my ($n) = @_;\n    $n < 2\n      ? ($n == 0 ? 1 : 0)\n      : (2 * $n - 1) * pi_nu($n - 1) + ($n - 1)**2 * pi_nu($n - 2);\n}\n\nsub pi_de {\n    my ($n) = @_;\n    $n < 2\n      ? $n\n      : (2 * $n - 1) * pi_de($n - 1) + ($n - 1)**2 * pi_de($n - 2);\n}\n\nmy $prec = 1000;\nmy $pi = as_dec(4 / (1 + pi_nu($prec) / pi_de($prec)), int($prec / 1.32));\nsay $pi;\n"
  },
  {
    "path": "Math/frobenius_pseudoprimes_generation.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 07 October 2018\n# Edit: 19 August 2020\n# https://github.com/trizen\n\n# A new algorithm for generating Frobenius pseudoprimes to Fibonacci polynomial x^2 - x - 1.\n\n# See also:\n#   https://oeis.org/A217120 -- Lucas pseudoprimes\n#   https://oeis.org/A217255 -- Strong Lucas pseudoprimes\n#   https://oeis.org/A177745 -- Semiprimes n such that n divides Fibonacci(n+1).\n#   https://oeis.org/A212423 -- Frobenius pseudoprimes == 2,3 (mod 5) with respect to Fibonacci polynomial x^2 - x - 1.\n\n# See also:\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse ntheory qw(:all);\nuse Math::AnyNum qw(prod);\n\nsub frobenius_pseudoprimes ($limit, $callback, $P = 1, $Q = -1) {\n\n    my %table;\n    my $D = $P*$P - 4*$Q;\n\n    forprimes {\n        my $p = $_;\n        foreach my $d (divisors($p - kronecker($D, $p))) {\n            if ((lucas_sequence($p, $P, $Q, $d))[0] == 0) {\n                push @{$table{$d}}, $p;\n                last;\n            }\n        }\n    } 3, $limit;\n\n    foreach my $arr (values %table) {\n\n        my $l = $#{$arr} + 1;\n\n        foreach my $k (2 .. $l) {\n            forcomb {\n                my $n = prod(@{$arr}[@_]);\n                $callback->($n, @{$arr}[@_]);\n            } $l, $k;\n        }\n    }\n}\n\nmy @pseudoprimes;\n\nfrobenius_pseudoprimes(\n    100_000,\n    sub ($n, @f) {\n\n        is_frobenius_pseudoprime($n, 1, -1) or die \"error: $n\";\n\n        push @pseudoprimes, $n;\n\n        if (kronecker(5, $n) == -1 and powmod(2, $n-1, $n) == 1) {\n            die \"Found a BPSW counter-example: $n = prod(@f)\";\n        }\n    }\n);\n\n@pseudoprimes = sort { $a <=> $b } @pseudoprimes;\n\nsay join(', ', @pseudoprimes);\n\n__END__\n4181, 5777, 10877, 13201, 15251, 64079, 64681, 67861, 75077, 97921, 100127, 113573, 118441, 161027, 162133, 219781, 231703, 254321, 272611, 330929, 430127, 556421, 638189, 722261, 741751, 851927, 999941, 1033997, 1106561, 1149851, 1256293, 1346269, 1392169, 1690501, 2159389, 2187841, 2221811, 2263127, 2362081, 2435423, 2465101, 2476549, 2559929, 2586229, 2662277, 3175883, 3188011, 3218801, 3399527, 3568661, 3636121, 3663871, 4226777, 4250681, 4403027, 4868641, 4870847, 4974481, 5208377, 5328181, 5800001, 5942627, 6003923, 6192721, 6359021, 6374111, 6884131, 7067171, 7369601, 7879681, 7947701, 7961801, 8518127, 8655511, 8834641, 9401893, 9476741, 9713027, 9922337, 10054043, 10403641, 10604431, 10837601, 11487961, 11637583, 12178241, 12962291, 13012651, 13277423, 13404751, 13455077, 14015843, 14787181, 14892541, 14985833, 15287009, 15754007, 16233361, 16485493, 16685003, 18552361, 18557951, 19168477, 20551301, 21692189, 21850951, 21988961, 22361327, 22556801, 22591301, 23292361, 23307377, 24157817, 24236461, 24493061, 25532501, 25707841, 27236311, 29604893, 29971811, 30299333, 31150351, 31155001, 31181581, 31530241, 31673333, 32092259, 32377591, 32702723, 32815361, 33664651, 33796531, 34134407, 34379101, 35365111, 35452891, 36574849, 39247393, 40433551, 40465501, 40629601, 40675981, 41177993, 41808581, 42149971, 42389027, 42525773, 43259221, 43701901, 44111629, 44370481, 46114921, 47219201, 47297543, 49219673, 51132251, 51931333, 52448371, 53835031, 54675571, 55530161, 55681841, 55726849, 57028949, 57280081, 57464207, 57903361, 59268827, 60881921, 61218901, 61770041, 64610027, 66124001, 66347849, 66796529, 67237883, 70894277, 73295777, 73693369, 73780877, 74580767, 75239513, 75245777, 77337941, 77642881, 77862391, 78430801, 83241013, 83963177, 83967361, 84292249, 84792811, 85015493, 85090339, 85518229, 85903277, 87160061, 87471017, 89190301, 89784581, 89816411, 93591569, 95452781, 97894501, 98385377, 100224001, 101159119, 101873441, 104943827, 106314931, 109231229, 110734667, 116853827, 117987841, 119710951, 120485381, 121152961, 121226531, 122505571, 123247001, 124477513, 127835341, 131369801, 132162581, 132245291, 136579127, 138652879, 139904627, 140707921, 142593827, 143548501, 145206361, 146206901, 148436209, 148472347, 152396641, 154285721, 157132127, 157793659, 158197577, 159160751, 161216021, 161438671, 163578827, 165580141, 166850777, 167364161, 168018353, 168600329, 170173741, 170371021, 170434181, 171147601, 171284521, 171579883, 172004641, 173603561, 174413441, 175007251, 175147081, 176150179, 177285281, 177439061, 177455701, 177961639, 177991277, 180353321, 184135673, 184746889, 185504633, 186003827, 188649001, 189003781, 192227027, 194907511, 199118221, 199137121, 200791009, 203231621, 207023087, 210089303, 211099877, 221360641, 224056801, 224418401, 226525883, 226965751, 226982209, 234610291, 234755489, 239806561, 243100859, 245609041, 245795201, 247030877, 247882963, 253158751, 255866131, 256529761, 257094661, 257815277, 259179527, 264689963, 272087749, 274937851, 275946581, 276795217, 277932113, 280075277, 284301751, 284344141, 284828777, 285542711, 287375681, 289140101, 291501061, 294465761, 302784751, 302818001, 305464661, 306219377, 310701119, 312189697, 316701527, 318026801, 319287151, 324010061, 324186451, 328118281, 345701731, 351339649, 354870431, 359089091, 360783793, 364021549, 368468689, 374223991, 374654681, 375578683, 376682627, 377224051, 380182661, 382211681, 386628527, 387009737, 396106261, 400091327, 400253701, 400657277, 401005351, 401790377, 402798881, 403460429, 407282851, 410925871, 417027451, 423933241, 425612641, 429802001, 432988877, 433936141, 438424561, 439036421, 439744397, 443146057, 443969063, 448504697, 450825377, 455039027, 456780193, 461700077, 461807147, 464407883, 469721647, 475167377, 477086741, 477875231, 480053573, 480891143, 485326403, 487266991, 488248661, 488458381, 489290551, 492600439, 495101777, 504097397, 504455201, 509108081, 511121161, 511408171, 516980641, 519809701, 523827527, 527168149, 532258271, 532853441, 535702301, 540136277, 544915541, 547281851, 551313001, 557112641, 558526081, 562046627, 569720321, 570122027, 573707779, 574181327, 577647017, 583031693, 583979551, 584238563, 594301999, 598147577, 598768609, 609903521, 611463169, 611928901, 623709217, 629130449, 634002181, 634888253, 635165701, 638227127, 651861761, 657665777, 659846021, 664939277, 670042903, 670786877, 681977941, 686258627, 691455077, 691543049, 692726473, 692956819, 700190741, 704907377, 717915631, 723606391, 726357781, 729790381, 733198069, 734494801, 734498627, 738803341, 738820351, 743512001, 747587777, 748691591, 756647719, 760131139, 765947911, 768614027, 768916661, 772719947, 779566211, 780421277, 783794201, 788342777, 799500077, 808914881, 811541327, 814507541, 815496481, 818208901, 818762689, 823951171, 825393997, 829737221, 832108051, 839350363, 847053323, 847887823, 854573591, 856901267, 863097377, 865431841, 869420473, 873933527, 878330573, 879706741, 879995689, 887467621, 902096161, 922483693, 925625341, 943685959, 957600541, 961095923, 969210377, 976396961, 978920627, 982540421, 982566001, 985125077, 997540711, 999260501, 1012601251, 1015183343, 1015269391, 1032469817, 1037627051, 1050535501, 1052823241, 1054740191, 1055586377, 1058277151, 1060019221, 1064519011, 1072839941, 1085197577, 1089855841, 1105376491, 1107004579, 1112103541, 1113330077, 1113690401, 1140573601, 1157839381, 1168706449, 1171643027, 1173580127, 1177778671, 1179985921, 1189091821, 1189596241, 1189817371, 1194143443, 1198880261, 1221767831, 1226486627, 1230253133, 1232097751, 1238517649, 1260782161, 1277310731, 1280000357, 1293886001, 1295786777, 1296715741, 1298835361, 1308489103, 1309056527, 1329329041, 1344725839, 1345118777, 1352581201, 1364001113, 1371177527, 1388116201, 1389975149, 1397169091, 1401927301, 1435476803, 1437954377, 1440231941, 1447631281, 1451648021, 1469268961, 1477822433, 1479714109, 1480849831, 1490926471, 1496207809, 1524039373, 1538321777, 1540208251, 1541651627, 1554381041, 1561706327, 1569202181, 1572777551, 1613842001, 1620370127, 1637181571, 1663923827, 1669944911, 1695570841, 1749213377, 1757470643, 1769148751, 1776917381, 1783687127, 1826950127, 1831812841, 1841923841, 1885440527, 1897742027, 1912283521, 1922485969, 1942700321, 1966151713, 1976436001, 1986232877, 2025112501, 2031527803, 2044641377, 2053059121, 2054711381, 2087064527, 2105502571, 2132534777, 2141087051, 2179815377, 2184948481, 2205763129, 2207635127, 2241989381, 2261715461, 2271885527, 2273233877, 2297795249, 2305256171, 2336003647, 2346515201, 2382397877, 2387525141, 2407312577, 2411416883, 2444927627, 2470214251, 2489587361, 2509684127, 2512436189, 2525294777, 2535254027, 2563596751, 2564590757, 2630493643, 2630997541, 2641736327, 2660668877, 2673518921, 2683425889, 2767644017, 2774193827, 2776175491, 2823296341, 2832598277, 2834103827, 2837116127, 2860846721, 2887050077, 2918947111, 2970486251, 2985547447, 2986528151, 3012261281, 3054233761, 3086865941, 3174423947, 3181427027, 3197545121, 3197911001, 3223978421, 3229317529, 3234291377, 3264492481, 3295217971, 3304861061, 3316826083, 3331524377, 3332800021, 3400444277, 3435168827, 3447642571, 3453240551, 3502970551, 3525270527, 3532275919, 3558410813, 3560625077, 3596180011, 3601246277, 3625296109, 3690049277, 3717318961, 3744599777, 3747570989, 3749780509, 3752161877, 3797343377, 3804550901, 3860348777, 3881456123, 3923872577, 3966509777, 3987794201, 4068854957, 4092184277, 4141182527, 4146469181, 4188641627, 4249267577, 4265877527, 4484755277, 4550723101, 4567911571, 4601042627, 4622170877, 4639493627, 4681974527, 4701994681, 4753271251, 4998750077, 5025964481, 5134523431, 5294024413, 5321159461, 5362854071, 5388200929, 5579401229, 5981643071, 6226972861, 6294834551, 6316490251, 6454495741, 6483278869, 6641648129, 6698324881, 9316736371, 11851534697, 22200933343, 41952920641, 43015909529, 52396612381, 98831168617, 101590045727, 132258145321, 144901909651, 147624283951, 172336503151, 192900153617, 261692085691, 353833078717, 563482421611, 671092578683, 820010859361, 962298554101, 1118047771487, 1177425963001, 1470477389131, 1531650766141, 1570279465921, 1709238394189, 1964576416861, 2028221720101, 2530176740309, 3024101746009, 3157425845701, 3225594892781, 3357827162143, 3530825173441, 3763183020911, 4001021039989, 5068919516491, 5242348423051, 5324864903273, 7526211756101, 8187215713601, 8932423389707, 12328859182621, 15181669854209, 17241996257089, 18846129954107, 19894139495311, 22784540748751, 29155619954281, 29469429987317, 29805368950421, 30557495038379, 35328926825531, 54955791883981, 61697862344329, 67713696400981, 74022949251469, 82433023161451, 96908287850239, 112154241154831, 247287106198211, 247640483709109, 2038201087420801, 5723467606147861, 9433259220189751, 61561639243505213, 183571830943059491, 3407863610517545791\n"
  },
  {
    "path": "Math/fubini_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 03 December 2017\n# https://github.com/trizen\n\n# A new algorithm for computing the Fubini numbers.\n\n# See also:\n#   https://oeis.org/A000670\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload factorial);\n\nsub fubini_numbers {\n    my ($n) = @_;\n\n    my @F = (1);\n\n    foreach my $i (1 .. $n) {\n        foreach my $k (0 .. $i - 1) {\n            $F[$i] += $F[$k] / factorial($i - $k);\n        }\n    }\n\n    map { $F[$_] * factorial($_) } 0 .. $#F;\n}\n\nmy @F = fubini_numbers(20);\n\nforeach my $i (0 .. $#F) {\n    say \"F($i) = $F[$i]\";\n}\n\n__END__\nF(0) = 1\nF(1) = 1\nF(2) = 3\nF(3) = 13\nF(4) = 75\nF(5) = 541\nF(6) = 4683\nF(7) = 47293\nF(8) = 545835\nF(9) = 7087261\nF(10) = 102247563\nF(11) = 1622632573\nF(12) = 28091567595\nF(13) = 526858348381\nF(14) = 10641342970443\nF(15) = 230283190977853\nF(16) = 5315654681981355\nF(17) = 130370767029135901\nF(18) = 3385534663256845323\nF(19) = 92801587319328411133\nF(20) = 2677687796244384203115\n"
  },
  {
    "path": "Math/fubini_numbers_2.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 05 February 2023\n# https://github.com/trizen\n\n# A new algorithm for computing the first n Fubini numbers.\n\n# See also:\n#   https://oeis.org/A000670\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload binomial);\n\nsub fubini_numbers {\n    my ($n) = @_;\n\n    my @F = (1);\n\n    foreach my $i (1 .. $n) {\n        foreach my $k (0 .. $i - 1) {\n            $F[$i] += $F[$k] * binomial($i, $k);\n        }\n    }\n\n    return @F;\n}\n\nmy @F = fubini_numbers(20);\n\nforeach my $i (0 .. $#F) {\n    say \"F($i) = $F[$i]\";\n}\n\n__END__\nF(0) = 1\nF(1) = 1\nF(2) = 3\nF(3) = 13\nF(4) = 75\nF(5) = 541\nF(6) = 4683\nF(7) = 47293\nF(8) = 545835\nF(9) = 7087261\nF(10) = 102247563\nF(11) = 1622632573\nF(12) = 28091567595\nF(13) = 526858348381\nF(14) = 10641342970443\nF(15) = 230283190977853\nF(16) = 5315654681981355\nF(17) = 130370767029135901\nF(18) = 3385534663256845323\nF(19) = 92801587319328411133\nF(20) = 2677687796244384203115\n"
  },
  {
    "path": "Math/fubini_numbers_recursive.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 03 January 2019\n# https://github.com/trizen\n\n# A recursive formula for computing the Fubini numbers.\n\n# See also:\n#   https://oeis.org/A000670\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Memoize qw(memoize);\nuse Math::AnyNum qw(:overload binomial sum);\n\nmemoize('nth_fubini_number');\n\nsub nth_fubini_number {\n    my ($n) = @_;\n    return 1 if ($n == 0);\n    sum(map { nth_fubini_number($_) * binomial($n, $_) } 0 .. $n-1);\n}\n\nforeach my $i (0 .. 20) {\n    say \"F($i) = \", nth_fubini_number($i);\n}\n\n__END__\nF(0) = 1\nF(1) = 1\nF(2) = 3\nF(3) = 13\nF(4) = 75\nF(5) = 541\nF(6) = 4683\nF(7) = 47293\nF(8) = 545835\nF(9) = 7087261\nF(10) = 102247563\nF(11) = 1622632573\nF(12) = 28091567595\nF(13) = 526858348381\nF(14) = 10641342970443\nF(15) = 230283190977853\nF(16) = 5315654681981355\nF(17) = 130370767029135901\nF(18) = 3385534663256845323\nF(19) = 92801587319328411133\nF(20) = 2677687796244384203115\n"
  },
  {
    "path": "Math/function_graph.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 02 July 2014\n# https://github.com/trizen\n\n# Map a mathematical function on the xOy axis.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\n# Generic creation of a matrix\nsub create_matrix {\n    my ($size, $val) = @_;\n    int($size / 2), [map { [($val) x ($size)] } 0 .. $size - 1];\n}\n\n# Create a matrix\nmy ($i, $matrix) = create_matrix(65, ' ');\n\n# Assign the point inside the matrix\nsub assign {\n    my ($x, $y, $value) = @_;\n\n    $x += $i;\n    $y += $i + 1;\n\n    $matrix->[-$y][$x] = $value;\n}\n\n# Map the function\nforeach my $x (-5 .. 5) {\n    my $fx = $x**2 + 1;    # this is the function\n    say \"($x, $fx)\";       # this line prints the coordinates\n    assign($x, $fx, 'o');  # this line maps the value of (x, f(x)) on the graph\n}\n\n# Display the graph\nwhile (my ($k, $row) = each @{$matrix}) {\n    while (my ($l, $col) = each @{$row}) {\n        if ($col eq ' ') {\n            if ($k == $i) {    # the 'x' line\n                print '-';\n            }\n            elsif ($l == $i) {    # the 'y' line\n                print '|';\n            }\n            else {                # space\n                print $col;\n            }\n        }\n        else {                    # everything else\n            print $col;\n        }\n    }\n    print \"\\n\";                   # new line\n}\n"
  },
  {
    "path": "Math/function_inverse_binary_search.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 10 July 2019\n# https://github.com/trizen\n\n# Compute the inverse of any function, using the binary search algorithm.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Binary_search_algorithm\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload approx_cmp float);\n\nsub binary_inverse ($n, $f, $min = 0, $max = $n, $prec = 192) {\n\n    local $Math::AnyNum::PREC = \"$prec\";\n\n    ($min, $max) = ($max, $min) if ($min > $max);\n\n    $min = float($min);\n    $max = float($max);\n\n    for (; ;) {\n        my $m = ($min + $max) / 2;\n        my $c = approx_cmp($f->($m), $n);\n\n        if ($c < 0) {\n            $min = $m;\n        }\n        elsif ($c > 0) {\n            $max = $m;\n        }\n        else {\n            return $m;\n        }\n    }\n}\n\nsay binary_inverse(2,   sub ($x) { exp($x) });    # solution to x for: exp(x) =   2\nsay binary_inverse(43,  sub ($x) { $x**2 });      # solution to x for:    x^2 =  43\nsay binary_inverse(-43, sub ($x) { $x**3 });      # solution to x for:    x^3 = -43\n\n# Find the value of x such that Li(x) = 100\nsay binary_inverse(100, sub ($x) { Math::AnyNum::Li($x) }, 1, 1e6);    #=> 488.871909852807531906050863920333348273780185564\n"
  },
  {
    "path": "Math/gamma_function.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 17 November 2015\n# Website: https://github.com/trizen\n\n# The gamma function implemented as an improper integral\n# See: https://en.wikipedia.org/wiki/Gamma_function\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub gamma {\n    my ($n) = @_;\n\n    my $sum = 0;\n    for my $t (0 .. 1000) {\n        $sum += $t**($n - 1) * exp(-$t);\n    }\n\n    return $sum;\n}\n\nfor my $n (1 .. 20) {\n    printf \"gamma(%2d) = %.24f\\n\", $n, gamma($n);\n}\n"
  },
  {
    "path": "Math/gaussian_divisors.pl",
    "content": "#!/usr/bin/perl\r\n\r\n# Author: Trizen\r\n# Date: 13 June 2022\r\n# https://github.com/trizen\r\n\r\n# Find the factors and divisors of a Gaussian integer.\r\n\r\n# See also:\r\n#   https://oeis.org/A125271\r\n#   https://oeis.org/A078930\r\n#   https://oeis.org/A078910\r\n#   https://oeis.org/A078911\r\n#   https://projecteuler.net/problem=153\r\n#   https://www.alpertron.com.ar/GAUSSIAN.HTM\r\n#   https://en.wikipedia.org/wiki/Table_of_Gaussian_integer_factorizations\r\n\r\nuse 5.020;\r\nuse strict;\r\nuse warnings;\r\n\r\nuse ntheory qw(:all);\r\nuse experimental qw(signatures);\r\n\r\nsub gaussian_mul ($xa, $xb, $ya, $yb) {\r\n    ($xa * $ya - $xb * $yb, $xa * $yb + $xb * $ya)\r\n}\r\n\r\nsub gaussian_div ($xa, $xb, $ya, $yb) {    # floor division\r\n    my $t = $ya * $ya + $yb * $yb;\r\n    (\r\n        divint($ya * $t * $xa - $t * -$yb * $xb, $t * $t),\r\n        divint($ya * $t * $xb + $t * -$yb * $xa, $t * $t)\r\n    );\r\n}\r\n\r\nsub gaussian_is_div ($xa, $xb, $ya, $yb) {\r\n    my ($ta, $tb) = gaussian_mul($ya, $yb, gaussian_div($xa, $xb, $ya, $yb));\r\n    $xa - $ta == 0 and $xb - $tb == 0;\r\n}\r\n\r\nsub primitive_sum_of_two_squares ($p) {\r\n\r\n    if ($p == 2) {\r\n        return (1, 1);\r\n    }\r\n\r\n    my $s = sqrtmod(-1, $p) || return;\r\n    my $q = $p;\r\n\r\n    while ($s * $s > $p) {\r\n        ($s, $q) = ($q % $s, $s);\r\n    }\r\n\r\n    ($s, $q % $s);\r\n}\r\n\r\nsub gaussian_factors ($x, $y = 0) {\r\n\r\n    return if ($x == 0 and $y == 0);\r\n\r\n    my $n = ($x * $x + $y * $y);\r\n    my @factors;\r\n\r\n    foreach my $pe (factor_exp($n)) {\r\n        my ($p, $e) = @$pe;\r\n\r\n        if ($p == 2) {\r\n            while (gaussian_is_div($x, $y, 1, 1)) {\r\n                push @factors, [1, 1];\r\n                ($x, $y) = gaussian_div($x, $y, 1, 1);\r\n            }\r\n        }\r\n        elsif ($p % 4 == 3) {\r\n            while (gaussian_is_div($x, $y, $p, 0)) {\r\n                push @factors, [$p, 0];\r\n                ($x, $y) = gaussian_div($x, $y, $p, 0);\r\n            }\r\n        }\r\n        elsif ($p % 4 == 1) {\r\n            my ($a, $b) = primitive_sum_of_two_squares($p);\r\n\r\n            while (gaussian_is_div($x, $y, $a, $b)) {\r\n                push @factors, [$a, $b];\r\n                ($x, $y) = gaussian_div($x, $y, $a, $b);\r\n            }\r\n\r\n            while (gaussian_is_div($x, $y, $a, -$b)) {\r\n                push @factors, [$a, -$b];\r\n                ($x, $y) = gaussian_div($x, $y, $a, -$b);\r\n            }\r\n        }\r\n    }\r\n\r\n    if ($x == 1 and $y == 0) {\r\n        ## ok\r\n    }\r\n    else {\r\n        push @factors, [$x, $y];\r\n    }\r\n\r\n    @factors = sort {\r\n        ($a->[0] <=> $b->[0]) ||\r\n        ($a->[1] <=> $b->[1])\r\n    } @factors;\r\n\r\n    my %count;\r\n    $count{join(' ', @$_)}++ for @factors;\r\n\r\n    my %seen;\r\n    my @factor_exp =\r\n        map { [$_, $count{join(' ', @$_)}] }\r\n        grep { !$seen{join(' ', @$_)}++ } @factors;\r\n\r\n    return @factor_exp;\r\n}\r\n\r\nsub gaussian_divisors ($x, $y = 0) {\r\n\r\n    my @d = ([1, 0], [-1, 0], [0, 1], [0, -1]);\r\n\r\n    foreach my $pe (gaussian_factors($x, $y)) {\r\n        my ($p,  $e)  = @$pe;\r\n        my ($ra, $rb) = (1, 0);\r\n        my @t;\r\n        for (1 .. $e) {\r\n            ($ra, $rb) = gaussian_mul($ra, $rb, $p->[0], $p->[1]);\r\n            foreach my $u (@d) {\r\n                push @t, [gaussian_mul($u->[0], $u->[1], $ra, $rb)];\r\n            }\r\n        }\r\n        push @d, @t;\r\n    }\r\n\r\n    @d = sort {\r\n        ($a->[0] <=> $b->[0]) ||\r\n        ($a->[1] <=> $b->[1])\r\n    } @d;\r\n\r\n    my %seen;\r\n    @d = grep { !$seen{join(' ', @$_)}++ } @d;\r\n\r\n    return @d;\r\n}\r\n\r\nsay scalar gaussian_divisors(440, -55);    #=> 96\r\n\r\nsay join ', ', map {\r\n    scalar grep { $_->[0] > 0 } gaussian_divisors($_, 0)\r\n} 0 .. 30;    # A125271\r\n\r\nsay join ', ', map {\r\n    vecsum(map { $_->[0] } grep { $_->[0] > 0 } gaussian_divisors($_, 0))\r\n} 0 .. 30;    # A078930\r\n\r\nsay join ', ', map {\r\n    vecsum(map { $_->[0] } grep { $_->[0] > 0 and $_->[1] > 0 } gaussian_divisors($_, 0))\r\n} 0 .. 30;    # A078911\r\n\r\nsay join ', ', map {\r\n    vecsum(map { $_->[0] } grep { $_->[0] > 0 or $_->[1] > 0 } gaussian_divisors($_, 0))\r\n} 0 .. 30;    # A078910\r\n\r\nmy $sum = 0;\r\n\r\nforeach my $n (1 .. 1000) {\r\n    $sum += vecsum(map { $_->[0] } grep { $_->[0] > 0 } gaussian_divisors($n, 0));\r\n}\r\n\r\nsay $sum;     #=> 1752541\r\n"
  },
  {
    "path": "Math/gaussian_factors.pl",
    "content": "#!/usr/bin/perl\r\n\r\n# Author: Trizen\r\n# Date: 13 June 2022\r\n# https://github.com/trizen\r\n\r\n# Find the factors of a Gaussian integer.\r\n\r\n# See also:\r\n#   https://www.alpertron.com.ar/GAUSSIAN.HTM\r\n#   https://en.wikipedia.org/wiki/Table_of_Gaussian_integer_factorizations\r\n\r\nuse 5.020;\r\nuse strict;\r\nuse warnings;\r\n\r\nuse ntheory qw(:all);\r\nuse experimental qw(signatures);\r\n\r\nsub gaussian_mul ($xa, $xb, $ya, $yb) {\r\n    ($xa * $ya - $xb * $yb, $xa * $yb + $xb * $ya)\r\n}\r\n\r\nsub gaussian_div ($xa, $xb, $ya, $yb) {    # floor division\r\n    my $t = $ya * $ya + $yb * $yb;\r\n    (\r\n        divint($ya * $t * $xa - $t * -$yb * $xb, $t * $t),\r\n        divint($ya * $t * $xb + $t * -$yb * $xa, $t * $t)\r\n    );\r\n}\r\n\r\nsub gaussian_is_div ($xa, $xb, $ya, $yb) {\r\n    my ($ta, $tb) = gaussian_mul($ya, $yb, gaussian_div($xa, $xb, $ya, $yb));\r\n    $xa - $ta == 0 and $xb - $tb == 0;\r\n}\r\n\r\nsub primitive_sum_of_two_squares ($p) {\r\n\r\n    if ($p == 2) {\r\n        return (1, 1);\r\n    }\r\n\r\n    my $s = sqrtmod(-1, $p) || return;\r\n    my $q = $p;\r\n\r\n    while ($s * $s > $p) {\r\n        ($s, $q) = ($q % $s, $s);\r\n    }\r\n\r\n    ($s, $q % $s);\r\n}\r\n\r\nsub gaussian_factors ($x, $y = 0) {\r\n\r\n    return if ($x == 0 and $y == 0);\r\n\r\n    my $n = ($x * $x + $y * $y);\r\n    my @factors;\r\n\r\n    foreach my $pe (factor_exp($n)) {\r\n        my ($p, $e) = @$pe;\r\n\r\n        if ($p == 2) {\r\n            while (gaussian_is_div($x, $y, 1, 1)) {\r\n                push @factors, [1, 1];\r\n                ($x, $y) = gaussian_div($x, $y, 1, 1);\r\n            }\r\n        }\r\n        elsif ($p % 4 == 3) {\r\n            while (gaussian_is_div($x, $y, $p, 0)) {\r\n                push @factors, [$p, 0];\r\n                ($x, $y) = gaussian_div($x, $y, $p, 0);\r\n            }\r\n        }\r\n        elsif ($p % 4 == 1) {\r\n            my ($a, $b) = primitive_sum_of_two_squares($p);\r\n\r\n            while (gaussian_is_div($x, $y, $a, $b)) {\r\n                push @factors, [$a, $b];\r\n                ($x, $y) = gaussian_div($x, $y, $a, $b);\r\n            }\r\n\r\n            while (gaussian_is_div($x, $y, $a, -$b)) {\r\n                push @factors, [$a, -$b];\r\n                ($x, $y) = gaussian_div($x, $y, $a, -$b);\r\n            }\r\n        }\r\n    }\r\n\r\n    if ($x == 1 and $y == 0) {\r\n        ## ok\r\n    }\r\n    else {\r\n        push @factors, [$x, $y];\r\n    }\r\n\r\n    @factors = sort {\r\n        ($a->[0] <=> $b->[0]) ||\r\n        ($a->[1] <=> $b->[1])\r\n    } @factors;\r\n\r\n    my %count;\r\n    $count{join(' ', @$_)}++ for @factors;\r\n\r\n    my %seen;\r\n    my @factor_exp =\r\n      map { [$_, $count{join(' ', @$_)}] }\r\n      grep { !$seen{join(' ', @$_)}++ } @factors;\r\n\r\n    return @factor_exp;\r\n}\r\n\r\nmy $z       = [440, -55];\r\nmy @factors = gaussian_factors($z->[0], $z->[1]);\r\n\r\nsay join(' ', map { '[' . join(', ', @{$_->[0]}) . ']' . ($_->[1] > 1 ? ('^' . $_->[1]) : '') } @factors);\r\n\r\nmy ($x, $y) = (1, 0);\r\nforeach my $pe (@factors) {\r\n    my ($p, $e) = @$pe;\r\n    for (1 .. $e) {\r\n        ($x, $y) = gaussian_mul($x, $y, $p->[0], $p->[1]);\r\n    }\r\n}\r\n\r\nsay \"Product of factors: [$x, $y]\";\r\n\r\n__END__\r\n[2, -1] [2, 1]^2 [3, -2] [11, 0]\r\nProduct of factors: [440, -55]\r\n"
  },
  {
    "path": "Math/gaussian_integers_sum.pl",
    "content": "#!/usr/bin/perl\n\n# Calculate the terms of the sequences A281964 (real part) and A282132 (imaginary part), using\n# Math::AnyNum and Math::GComplex, but without doing any floating-point arithmetic operations.\n\n# See also:\n#   https://oeis.org/A281964\n#   https://oeis.org/A282132\n#   https://en.wikipedia.org/wiki/Gaussian_integer\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Math::GComplex qw(cplx);\nuse Math::AnyNum qw(:overload factorial);\n\nsub A281964_A282132 ($n) {\n\n    my @i = (1, cplx(0, 1), -1, cplx(0, -1));\n\n    my $sum = cplx(0, 0);\n\n    foreach my $k (1 .. $n) {\n        $sum += $i[($k - 1) % 4] / $k;\n    }\n\n    return $sum * factorial($n);\n}\n\nforeach my $n (1 .. 40) {\n    printf(\"%50s %s\\n\", A281964_A282132($n)->reals);\n}\n\n__END__\n                                                 1 0\n                                                 2 1\n                                                 4 3\n                                                16 6\n                                               104 30\n                                               624 300\n                                              3648 2100\n                                             29184 11760\n                                            302976 105840\n                                           3029760 1421280\n                                          29698560 15634080\n                                         356382720 147692160\n                                        5111976960 1919998080\n                                       71567677440 33106993920\n                                      986336870400 496604908800\n                                    15781389926400 6638004172800\n                                   289206418636800 112846070937600\n                                  5205715535462400 2386916704972800\n                                 92506221468057600 45351417394483200\n                               1850124429361152000 785383247480832000\n                              41285515024760832000 16493048197097472000\n                             908281330544738304000 413938002507853824000\n                           19766469874751373312000 9520574057680637952000\n                          474395276994032959488000 202641760645450334208000\n                        12480330326584063426560000 5066044016136258355200000\n                       324488588491185649090560000 147228354462873703219200000\n                      8357900428135406889861120000 3975165570497589986918400000\n                    234021211987791392916111360000 100415766523514167472947200000\n                   7091503492257664255068733440000 2912057229181910856715468800000\n                 212745104767729927652062003200000 96203478869197027656007680000000\n                6329845387987436698577613619200000 2982307844945107857336238080000000\n              202555052415597974354483635814400000 87211012384065528617034055680000000\n             6947447566648426683865177994035200000 2877963408674162444362123837440000000\n           236213217266046507251416051797196800000 106534073513733409603830404874240000000\n          7972229805272023612951943203258368000000 3728692572980669336134064170598400000000\n        287000272989792850066269955317301248000000 123899784660917951171159658804019200000000\n      10991003427412236669919987794890981376000000 4584292032453964193332907375748710400000000\n     417658130241664993456959536205857292288000000 187966850324476984392966459860031897600000000\n   15765644461958333633061414687928360108032000000 7330707162654602391325691934541244006400000000\n  630625778478333345322456587517134404321280000000 272830404424986652294387395641746862899200000000\n"
  },
  {
    "path": "Math/general_binary_multiplier.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 07 August 2015\n# Website: https://github.com/trizen\n\n# A general binary multiplier.\n# Derived from: https://en.wikipedia.org/wiki/Binary_multiplier#A_more_advanced_approach:_an_unsigned_example\n\nuse 5.010;\nuse strict;\nuse integer;\nuse warnings;\n\nmy $a = 4253;\nmy $b = 7149;\n\nmy @a = reverse(split(//, sprintf(\"%b\", $a)));\nmy @b = split(//, sprintf(\"%b\", $b));\n\nsay @a;\nsay @b;\n\nsay $a * $b;\n\nmy @p = (0) x (@a + @b);\n\nmy $k = 0;\nforeach my $i (@a) {\n    if ($i) {\n        say @p;\n        my $carry = 0;\n        foreach my $j (0 .. $#b) {\n            my $add = $b[$#b - $j] + $p[$#p - $j - $k] + $carry;\n            $p[$#p - $j - $k] = $add % 2;\n            $carry = $add / 2;\n        }\n        if ($carry) {\n            foreach my $j ($#b + 1 .. $#p) {\n                my $add = $carry + $p[$#p - $j - $k];\n                $p[$#p - $j - $k] = $add % 2;\n                $carry = ($add / 2) || last;\n            }\n        }\n    }\n    ++$k;\n}\n\nsay @p;\nsay unpack(\"N\", pack(\"B32\", substr(\"0\" x 32 . join('', @p), -32)));\n"
  },
  {
    "path": "Math/goldbach_conjecture_2n_prime.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 04 September 2015\n# Website: https://github.com/trizen\n\n# Goldbach conjecture as the sum of two primes\n# with one prime being in the range of (n, 2n)\n\n# Proving that always there is a prime number between\n# n and 2n which can be added with a smaller prime\n# such as the sum is 2n, would prove the conjecture.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse List::Util qw(sum);\nuse ntheory qw(random_prime is_prime);\n\nmy $max = 10000;\n\nmy @counts;\nforeach my $i (2 .. $max) {\n    my $n = 2 * $i;\n\n    my $count = 0;\n    while (1) {\n        ++$count;\n        last if is_prime($n - random_prime($i, $n));\n    }\n\n    push @counts, $count;\n}\n\nsay \"Expected: \", log($max) / 2;\nsay \"Observed: \", sum(@counts) / @counts;\n\n__END__\n--------------------------\n  Example for max=1000000\n--------------------------\nExpected: 6.90775527898214\nObserved: 6.66289466289466\n"
  },
  {
    "path": "Math/goldbach_conjecture_increasing_primes.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 16 September 2016\n# Website: https://github.com/trizen\n\n# The smallest prime p such that (2n - p) is also a prime number,\n# and the prime p is the largest prime seen so far.\n\n# Analyzing this sequence, may give us an insight into the Golbach's conjecture.\n\nuse strict;\nuse warnings;\n\nuse ntheory qw(primes is_prime);\n\nmy $limit  = 1000000;\nmy @primes = @{primes($limit)};\n\nmy $max = 0;\n\nOUTER: for (my $i = 4 ; $i <= $limit ; $i += 2) {\n    foreach my $p (@primes) {\n        if (is_prime($i - $p)) {\n\n            if ($p > $max) {\n                $max = $p;\n                printf(\"%7s %7s\\n\", $i, $p);\n            }\n\n            next OUTER;\n        }\n    }\n}\n\n__END__\n\nOutput for 2n <= 10^7:\n\n     n       p\n   -----   -----\n      4       2\n      6       3\n     12       5\n     30       7\n     98      19\n    220      23\n    308      31\n    556      47\n    992      73\n   2642     103\n   5372     139\n   7426     173\n  43532     211\n  54244     233\n  63274     293\n 113672     313\n 128168     331\n 194428     359\n 194470     383\n 413572     389\n 503222     523\n1077422     601\n3526958     727\n3807404     751\n"
  },
  {
    "path": "Math/goldbach_conjecture_possibilities.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 29 July 2015\n# Website: https://github.com/trizen\n\n# Calculate the number of combinations for the Goldbach conjecture\n# for all the numbers ranging between the two exponents of e.\n\n# As it seems, the number of combinations increases,\n# with each power and it seems to go towards infinity.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(forprimes is_prime pn_primorial nth_prime);\n\nmy $primo = 2;\nmy $count = 1;\n\nmy %table;\nforeach my $i (1 .. pn_primorial(5)) {\n    my $n = 2 * $i;\n    my $partition = $i <= $primo ? $primo : do {\n        $primo *= nth_prime(++$count);\n    };\n    forprimes {\n        is_prime($n - $_)\n          && ++$table{$partition};\n    }\n    ($n - 2);\n}\n\nuse Data::Dump qw(pp);\npp \\%table;\n\n__END__\n\nPrimorial partitions:\n{\n    2     => 1,\n    6     => 8,\n    30    => 149,\n    210   => 3696,\n    2310  => 218701,\n    30030 => 20096631\n}\n\nLogarithmic:\n{\n  1  => 2,\n  2  => 22,\n  3  => 109,\n  4  => 558,\n  5  => 2883,\n  6  => 15523,\n  7  => 85590,\n  8  => 484304,\n  9  => 2819301,\n  10 => 16797271,\n  11 => 101959227,\n}\n"
  },
  {
    "path": "Math/goldbach_conjecture_random_primes.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 04 September 2015\n# Website: https://github.com/trizen\n\n# Compute the average of choosing a random prime number\n# in a given range such as the difference between 2n\n# and a prime number to be another prime number.\n#\n# Example:\n#   is_prime(2n - rand_prime(2, 2n-2))   # true\n#\n# This problem is related to Goldbach conjecture.\n# It shows that we have to choose, on average,\n# log(n)/2 times a random prime number to satisfy\n# the above property. This is an important outcome!\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(\n    vecsum\n    is_prime\n    random_prime\n);\n\nmy $max = 100000;\n\nmy @counts;\nforeach my $i (2 .. $max) {\n    my $n = 2 * $i;\n\n    my $count = 0;\n    while (1) {\n        ++$count;\n        last if is_prime($n - random_prime(2, $n - 2));\n    }\n\n    push @counts, $count;\n}\n\nsay \"Expected: \", log($max) / 2;\nsay \"Observed: \", vecsum(@counts) / @counts;\n\n__END__\n--------------------------\n  Example for max=300000\n--------------------------\nExpected: 6.30576887681917\nObserved: 6.3850079500265\n"
  },
  {
    "path": "Math/golomb_s_sequence.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 29 November 2016\n# https://github.com/trizen\n\n# A recursive function that represents the Golomb's sequence.\n\n# See also:\n#   https://oeis.org/A001462\n#   https://projecteuler.net/problem=341\n#   https://en.wikipedia.org/wiki/Golomb_sequence\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nno warnings qw(recursion);\n\nuse experimental qw(signatures);\nuse Memoize qw(memoize);\n\nmemoize('G');    # this will save time\n\nsub G($n) {\n    $n == 1 ? 1 : 1 + G($n - G(G($n - 1)));\n}\n\nsay \"G(1000) = \", G(1000);\n"
  },
  {
    "path": "Math/greatest_common_unitary_divisor.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 13 September 2023\n# https://github.com/trizen\n\n# Efficient algorithm for finding the greatest common unitary divisor of a list of integers.\n\nuse 5.036;\nuse ntheory qw(:all);\n\nsub gcud (@list) {\n\n    my $g = gcd(@list);\n\n    foreach my $n (@list) {\n        next if ($n == 0);\n        while (1) {\n            my $t = gcd($g, divint($n, $g));\n            last if ($t == 1);\n            $g = divint($g, $t);\n        }\n        last if ($g == 1);\n    }\n\n    return $g;\n}\n\nsay gcud();                              #=> 0\nsay gcud(2);                             #=> 2\nsay gcud(10,           20);              #=> 5\nsay gcud(factorial(9), 5040);            #=> 35\nsay gcud(factorial(9), 5040, 120);       #=> 5\nsay gcud(factorial(9), 5040, 0, 120);    #=> 5\nsay gcud(factorial(9), 5040, 1234);      #=> 1\n"
  },
  {
    "path": "Math/hamming_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Generate the generalized Hamming numbers below a certain limit, given a set of primes.\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nsub hamming_numbers ($limit, $primes) {\n\n    my @h = (1);\n    foreach my $p (@$primes) {\n        foreach my $n (@h) {\n            if ($n * $p <= $limit) {\n                push @h, $n * $p;\n            }\n        }\n    }\n\n    return \\@h;\n}\n\n# Example: 5-smooth numbers below 100\nmy $h = hamming_numbers(100, [2, 3, 5]);\nsay join(', ', sort { $a <=> $b } @$h);\n"
  },
  {
    "path": "Math/harmonic_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 01 November 2016\n# https://github.com/trizen\n\n# Computing the nth-harmonic number as an exact fraction.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Harmonic_series_(mathematics)\n\nuse 5.016;\nuse warnings;\nuse Math::AnyNum;\n\nsub harmfrac {\n    my ($ui) = @_;\n\n    $ui = int($ui);\n    $ui || return Math::AnyNum->zero;\n    $ui < 0 and return Math::AnyNum->nan;\n\n    # Use binary splitting for large values of n. (by Fredrik Johansson)\n    # https://fredrik-j.blogspot.com/2009/02/how-not-to-compute-harmonic-numbers.html\n    if ($ui > 7000) {\n        my $num  = Math::GMPz::Rmpz_init_set_ui(1);\n        my $den  = Math::GMPz::Rmpz_init_set_ui($ui + 1);\n        my $temp = Math::GMPz::Rmpz_init();\n\n        # Inspired by Dana Jacobsen's code from Math::Prime::Util::{PP,GMP}.\n        #   https://metacpan.org/pod/Math::Prime::Util::PP\n        #   https://metacpan.org/pod/Math::Prime::Util::GMP\n        sub {\n            my ($num, $den) = @_;\n            Math::GMPz::Rmpz_sub($temp, $den, $num);\n\n            if (Math::GMPz::Rmpz_cmp_ui($temp, 1) == 0) {\n                Math::GMPz::Rmpz_set($den, $num);\n                Math::GMPz::Rmpz_set_ui($num, 1);\n            }\n            elsif (Math::GMPz::Rmpz_cmp_ui($temp, 2) == 0) {\n                Math::GMPz::Rmpz_set($den, $num);\n                Math::GMPz::Rmpz_mul_2exp($num, $num, 1);\n                Math::GMPz::Rmpz_add_ui($num, $num, 1);\n                Math::GMPz::Rmpz_addmul($den, $den, $den);\n            }\n            else {\n                Math::GMPz::Rmpz_add($temp, $num, $den);\n                Math::GMPz::Rmpz_tdiv_q_2exp($temp, $temp, 1);\n                my $q = Math::GMPz::Rmpz_init_set($temp);\n                my $r = Math::GMPz::Rmpz_init_set($temp);\n                __SUB__->($num, $q);\n                __SUB__->($r,   $den);\n                Math::GMPz::Rmpz_mul($num,  $num, $den);\n                Math::GMPz::Rmpz_mul($temp, $q,   $r);\n                Math::GMPz::Rmpz_add($num, $num, $temp);\n                Math::GMPz::Rmpz_mul($den, $den, $q);\n            }\n          }\n          ->($num, $den);\n\n        my $q = Math::GMPq::Rmpq_init();\n        Math::GMPq::Rmpq_set_num($q, $num);\n        Math::GMPq::Rmpq_set_den($q, $den);\n        Math::GMPq::Rmpq_canonicalize($q);\n\n        return Math::AnyNum->new($q);\n    }\n\n    my $num = Math::GMPz::Rmpz_init_set_ui(1);\n    my $den = Math::GMPz::Rmpz_init_set_ui(1);\n\n    for (my $k = 2 ; $k <= $ui ; ++$k) {\n        Math::GMPz::Rmpz_mul_ui($num, $num, $k);    # num = num * k\n        Math::GMPz::Rmpz_add($num, $num, $den);     # num = num + den\n        Math::GMPz::Rmpz_mul_ui($den, $den, $k);    # den = den * k\n    }\n\n    my $r = Math::GMPq::Rmpq_init();\n    Math::GMPq::Rmpq_set_num($r, $num);\n    Math::GMPq::Rmpq_set_den($r, $den);\n    Math::GMPq::Rmpq_canonicalize($r);\n\n    Math::AnyNum->new($r);\n}\n\nforeach my $i (0 .. 30) {\n    printf \"%20s / %-20s\\n\", harmfrac($i)->nude;\n}\n"
  },
  {
    "path": "Math/harmonic_numbers_from_digamma.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 26 May 2017\n# Edit: 04 November 2023\n# https://github.com/trizen\n\n# Computation of the nth-harmonic number, using the digamma(x) function.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Harmonic_number\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::GMPz             qw();\nuse Math::GMPq             qw();\nuse Math::MPFR             qw();\nuse Math::AnyNum           qw();\nuse Math::Prime::Util::GMP qw();\n\nsub harmonic {\n    my ($n) = @_;\n\n    $n == 0 and return Math::AnyNum->zero;\n    $n == 1 and return Math::AnyNum->one;\n\n    state $tau   = 6.28318530717958647692528676655900576839433879875;\n    state $gamma = 0.57721566490153286060651209008240243104215933594;\n\n    #my $log2_Hn = (-$n + $n * log($n) + (log($tau) + log($n)) / 2 + log(log($n) + $gamma)) / log(2);\n    my $log2_Hn = $n / log(2) + sqrt($n);\n\n    my $prec  = int($log2_Hn + 3);\n    my $round = Math::MPFR::MPFR_RNDN();\n\n    my $r = Math::MPFR::Rmpfr_init2($prec);\n    Math::MPFR::Rmpfr_set_ui($r, $n + 1, $round);\n    Math::MPFR::Rmpfr_digamma($r, $r, $round);\n\n    my $t = Math::MPFR::Rmpfr_init2($prec);\n    Math::MPFR::Rmpfr_const_euler($t, $round);\n    Math::MPFR::Rmpfr_add($r, $r, $t, $round);\n\n    my $num = Math::GMPz::Rmpz_init();\n    my $den = Math::GMPz::Rmpz_init();\n\n    Math::GMPz::Rmpz_set_str($den, Math::Prime::Util::GMP::consecutive_integer_lcm($n), 10);\n    Math::MPFR::Rmpfr_mul_z($r, $r, $den, $round);\n    Math::MPFR::Rmpfr_round($r, $r);\n    Math::MPFR::Rmpfr_get_z($num, $r, $round);\n\n    my $q = Math::GMPq::Rmpq_init();\n    Math::GMPq::Rmpq_set_num($q, $num);\n    Math::GMPq::Rmpq_set_den($q, $den);\n    Math::GMPq::Rmpq_canonicalize($q);\n    Math::AnyNum->new($q);\n}\n\nforeach my $i (0 .. 30) {\n    printf \"%20s / %-20s\\n\", harmonic($i)->nude;\n    harmonic($i) == Math::AnyNum::harmonic($i) or die \"error\";\n}\n\nforeach my $i (2863, 7000) {\n    harmonic($i) == Math::AnyNum::harmonic($i) or die \"error\";\n}\n\n__END__\n# Extra testing\nforeach my $k (1 .. 20) {\n    my $i = int(rand($k * 1e3));\n    say \"Testing: $i\";\n    harmonic($i) == Math::AnyNum::harmonic($i) or die \"error\";\n}\n"
  },
  {
    "path": "Math/harmonic_numbers_from_powers.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 29 July 2017\n# https://github.com/trizen\n\n# A high-level algorithm implementation for computing the nth-harmonic number, using perfect powers.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload idiv);\n\nsub harmonic_numbers_from_powers {\n    my ($n) = @_;\n\n    my @seen;\n    my $harm = $n <= 0 ? 0 : 1;\n\n    foreach my $k (2 .. $n) {\n        if (not exists $seen[$k]) {\n\n            my $p = $k;\n\n            do {\n                $seen[$p] = undef;\n            } while (($p *= $k) <= $n);\n\n            my $g = idiv($p, $k);\n            my $t = idiv($g - 1, $k - 1);\n\n            $harm += $t / $g;\n        }\n    }\n\n    return $harm;\n}\n\nforeach my $i (0 .. 30) {\n    printf \"%20s / %-20s\\n\", harmonic_numbers_from_powers($i)->nude;\n}\n"
  },
  {
    "path": "Math/harmonic_numbers_from_powers_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 29 July 2017\n# https://github.com/trizen\n\n# Computation of the nth-harmonic number, using perfect powers.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\n\nsub harmonic_numbers_from_powers {\n    my ($n) = @_;\n\n    my @seen;\n\n    my $num = Math::GMPz::Rmpz_init_set_ui($n <= 0 ? 0 : 1);\n    my $den = Math::GMPz::Rmpz_init_set_ui(1);\n\n    foreach my $k (2 .. $n) {\n        if (not exists $seen[$k]) {\n\n            my $p = $k;\n\n            do {\n                $seen[$p] = undef;\n            } while (($p *= $k) <= $n);\n\n            my $g = $p / $k;\n            my $t = ($g - 1) / ($k - 1);\n\n            Math::GMPz::Rmpz_mul_ui($num, $num, $g);\n\n            $t == 1\n              ? Math::GMPz::Rmpz_add($num, $num, $den)\n              : Math::GMPz::Rmpz_addmul_ui($num, $den, $t);\n\n            Math::GMPz::Rmpz_mul_ui($den, $den, $g);\n        }\n    }\n\n    my $gcd = Math::GMPz::Rmpz_init();\n\n    Math::GMPz::Rmpz_gcd($gcd, $num, $den);\n    Math::GMPz::Rmpz_divexact($num, $num, $gcd);\n    Math::GMPz::Rmpz_divexact($den, $den, $gcd);\n\n    return ($num, $den);\n}\n\nforeach my $n (0 .. 30) {\n    printf \"%20s / %-20s\\n\", harmonic_numbers_from_powers($n);\n}\n"
  },
  {
    "path": "Math/harmonic_prime_powers.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 29 July 2017\n# https://github.com/trizen\n\n# Harmonic sum of prime powers <= n, defined as:\n#\n#    Sum_{p <= n} (Sum_{1 <= k <= floor(log(n)/log(p))} 1/p^k)\n#\n# where p runs over the prime number <= n.\n\n# This is equivalent with:\n#   Sum_{p <= n} (p^(floor(log(n)/log(p))) - 1) / (p^(floor(log(n)/log(p))) * (p-1))\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(forprimes);\nuse Math::AnyNum qw(:overload ilog);\n\nsub harmonic_prime_powers {\n    my ($n) = @_;\n\n    my $sum = 0;\n\n    forprimes {\n        my $p = $_;\n        my $k = $p**ilog($n, $p);\n        $sum += ($k - 1) / ($k * ($p - 1));\n    } $n;\n\n    return $sum;\n}\n\nforeach my $n (1 .. 30) {\n    say harmonic_prime_powers($n);\n}\n\n__END__\n0\n1/2\n5/6\n13/12\n77/60\n77/60\n599/420\n1303/840\n4189/2520\n4189/2520\n48599/27720\n48599/27720\n659507/360360\n659507/360360\n659507/360360\n1364059/720720\n23909723/12252240\n23909723/12252240\n466536977/232792560\n466536977/232792560\n466536977/232792560\n466536977/232792560\n10963143031/5354228880\n10963143031/5354228880\n55886560931/26771144400\n55886560931/26771144400\n170634254393/80313433200\n170634254393/80313433200\n5028706810597/2329089562800\n5028706810597/2329089562800\n"
  },
  {
    "path": "Math/hybrid_prime_factorization.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 08 March 2018\n# https://github.com/trizen\n\n# A hybrid factorization algorithm, using:\n#   * Pollard's p-1 algorithm\n#   * Pollard's rho algorithm\n#   * A simple version of the continued-fraction factorization method\n#   * Fermat's factorization method\n\n# See also:\n#   https://en.wikipedia.org/wiki/Quadratic_sieve\n#   https://en.wikipedia.org/wiki/Dixon%27s_factorization_method\n#   https://en.wikipedia.org/wiki/Fermat%27s_factorization_method\n#   https://en.wikipedia.org/wiki/Pollard%27s_p_%E2%88%92_1_algorithm\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse ntheory qw(is_prime random_prime vecprod);\n\nuse Math::AnyNum qw(\n    gcd valuation powmod irand ipow\n    isqrt idiv is_square next_prime\n);\n\nsub fermat_hybrid_factorization ($n) {\n\n    return ()   if $n <= 1;\n    return ($n) if is_prime($n);\n\n    # Test for divisibility by 2\n    if (!($n & 1)) {\n\n        my $v = valuation($n, 2);\n        my $t = $n >> $v;\n\n        my @factors = (2) x $v;\n\n        if ($t > 1) {\n            push @factors, __SUB__->($t);\n        }\n\n        return @factors;\n    }\n\n    my $p = isqrt($n);\n    my $x = $p;\n    my $q = ($p * $p - $n);\n\n    my $t = 1;\n    my $h = 1;\n    my $z = Math::AnyNum->new(random_prime($n));\n\n    my $g = 1;\n    my $c = $q + $p;\n\n    my $a0 = 1;\n    my $a1 = ($a0 * $a0 + $c);\n    my $a2 = ($a1 * $a1 + $c);\n\n    my $c1 = $p;\n    my $c2 = 1;\n\n    my $r = $p + $p;\n\n    my ($e1, $e2) = (1, 0);\n    my ($f1, $f2) = (0, 1);\n\n    while (not is_square($q)) {\n\n        $q += 2 * $p++ + 1;\n\n        # Pollard's rho algorithm\n        $g = gcd($n, $a2 - $a1);\n\n        if ($g > 1 and $g < $n) {\n            return sort { $a <=> $b } (\n                __SUB__->($g),\n                __SUB__->($n / $g),\n            );\n        }\n\n        $a1 = (($a1 * $a1 + $c) % $n);\n        $a2 = (($a2 * $a2 + $c) % $n);\n        $a2 = (($a2 * $a2 + $c) % $n);\n\n        # Simple version of the continued-fraction factorization method.\n        # Efficient for numbers that have factors relatively close to sqrt(n)\n        $c1 = $r * $c2 - $c1;\n        $c2 = idiv($n - $c1 * $c1, $c2);\n\n        my $x1 = ($x * $f2 + $e2) % $n;\n        my $y1 = ($x1 * $x1) % $n;\n\n        if (is_square($y1)) {\n            $g = gcd($x1 - isqrt($y1), $n);\n\n            if ($g > 1 and $g < $n) {\n                return sort { $a <=> $b } (\n                    __SUB__->($g),\n                    __SUB__->($n / $g),\n                );\n            }\n        }\n\n        $r = idiv($x + $c1, $c2);\n\n        ($f1, $f2) = ($f2, ($r * $f2 + $f1) % $n);\n        ($e1, $e2) = ($e2, ($r * $e2 + $e1) % $n);\n\n        # Pollard's p-a algorithm (random variation)\n        $t = $z;\n        $h = next_prime($h);\n        $z = powmod($z, $h, $n);\n        $g = gcd($z * powmod($t, irand($n), $n) - 1, $n);\n\n        if ($g > 1) {\n\n            if ($g == $n) {\n                $h = 1;\n                $z = Math::AnyNum->new(random_prime($n));\n                next;\n            }\n\n            return sort { $a <=> $b } (\n                __SUB__->($g),\n                __SUB__->($n / $g),\n            );\n        }\n    }\n\n    # Fermat's method\n    my $s = isqrt($q);\n\n    return sort { $a <=> $b } (\n        __SUB__->($p + $s),\n        __SUB__->($p - $s),\n    );\n}\n\nmy @tests = map { Math::AnyNum->new($_) } qw(\n     160587846247027 5040 65127835124 6469693230\n     12129569695640600539 38568900844635025971879799293495379321\n     5057557777500469647488909553014309710588182149566739774380944488183531188525863600127265768146701283\n);\n\nforeach my $n (@tests) {\n\n    my @f = fermat_hybrid_factorization($n);\n\n    say \"$n = \", join(' * ', @f);\n    die 'error' if vecprod(@f) != $n;\n    die 'error' if grep { !is_prime($_) } @f;\n}\n\nsay \"\\n=> Factoring 2^k+1\";\n\nforeach my $k (1 .. 100) {\n\n    my $n = ipow(2, $k) + 1;\n    my @f = fermat_hybrid_factorization($n);\n\n    say \"2^$k + 1 = \", join(' * ', @f);\n    die 'error' if vecprod(@f) != $n;\n    die 'error' if grep { !is_prime($_) } @f;\n}\n\n# Test the continued-fraction method with factors relatively close to sqrt(n)\nforeach my $k (1 .. 100) {\n\n    my $p = random_prime(ipow(2, 100 + $k));\n    my $n = next_prime($p + irand(10**15)) * $p;\n    my @f = fermat_hybrid_factorization($n);\n\n    #say join(' * ', @f), \" = $n\";\n    die 'error' if vecprod(@f) != $n;\n    die 'error' if grep { !is_prime($_) } @f;\n}\n\n# Test for small numbers\nfor my $n (1 .. 1000) {\n\n    my @f = fermat_hybrid_factorization($n);\n\n    die 'error' if vecprod(@f) != $n;\n    die 'error' if grep { !is_prime($_) } @f;\n}\n"
  },
  {
    "path": "Math/infinitary_divisors.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 13 September 2023\n# https://github.com/trizen\n\n# Generate the infinitary divisors (or i-divisors) of n.\n\n# See also:\n#   https://oeis.org/A049417\n#   https://oeis.org/A077609\n\nuse 5.036;\nuse ntheory qw(:all);\n\nsub infinitary_divisors ($n) {\n\n    my @d = (1);\n\n    foreach my $pp (factor_exp($n)) {\n        my ($p, $e) = @$pp;\n\n        my @t;\n        my $r = 1;\n        foreach my $j (1 .. $e) {\n            $r = mulint($r, $p);\n            if (($e & $j) == $j) {\n                push @t, map { mulint($r, $_) } @d;\n            }\n        }\n        push @d, @t;\n    }\n\n    return sort { $a <=> $b } @d;\n}\n\nforeach my $n (1 .. 20) {\n    my @idivisors = infinitary_divisors($n);\n    say \"i-divisors of $n: [@idivisors]\";\n}\n\n__END__\ni-divisors of 1: [1]\ni-divisors of 2: [1 2]\ni-divisors of 3: [1 3]\ni-divisors of 4: [1 4]\ni-divisors of 5: [1 5]\ni-divisors of 6: [1 2 3 6]\ni-divisors of 7: [1 7]\ni-divisors of 8: [1 2 4 8]\ni-divisors of 9: [1 9]\ni-divisors of 10: [1 2 5 10]\ni-divisors of 11: [1 11]\ni-divisors of 12: [1 3 4 12]\ni-divisors of 13: [1 13]\ni-divisors of 14: [1 2 7 14]\ni-divisors of 15: [1 3 5 15]\ni-divisors of 16: [1 16]\ni-divisors of 17: [1 17]\ni-divisors of 18: [1 2 9 18]\ni-divisors of 19: [1 19]\ni-divisors of 20: [1 4 5 20]\n"
  },
  {
    "path": "Math/inverse_of_bernoulli_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 29 June 2017\n# Edit: 28 August 2023\n# https://github.com/trizen\n\n# Inverse of Bernoulli numbers, based on the inverse of the following asymptotic formula:\n#   |Bn| ~ 2 / (2*pi)^n * n!\n\n# Using Stirling's approximation for n!, we have:\n#   |Bn| ~ 2 / (2*pi)^n * sqrt(2*pi*n) * (n/e)^n\n\n# This gives us the following inverse formula:\n#   n ~ lgrt((|Bn| / (4*pi))^(1/(2*pi*e))) * 2*pi*e - 1/2\n\n# Where `lgrt(n)` is defined as:\n#   lgrt(x^x) = x\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload tau e LambertW lgrt log bernreal);\n\nsub inv_bern_W ($n) {\n    my $L = log($n / 2) - log(tau);\n    $L / LambertW($L / (tau * e)) - 1 / 2;\n}\n\nsub inv_bern_lgrt ($n) {\n    lgrt(($n / (2 * tau))**(1 / (e * tau))) * e * tau - 1 / 2;\n}\n\nmy $x = abs(bernreal(1000000));\n\nsay inv_bern_W($x);       #=> 999999.999999996521295786570230337488233833193417\nsay inv_bern_lgrt($x);    #=> 999999.999999996521295786570230337488233833193417\n"
  },
  {
    "path": "Math/inverse_of_euler_totient.pl",
    "content": "#!/usr/bin/perl\n\n# Given a positive integer `n`, this algorithm finds all the numbers k such that φ(k) = n.\n\nuse utf8;\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(is_prime divisors valuation);\n\nbinmode(STDOUT, ':utf8');\n\n# Based on Dana Jacobsen's code from Math::Prime::Util,\n# which in turn is based on invphi.gp v1.3 by Max Alekseyev.\n\n# See also:\n#   https://projecteuler.net/problem=248\n#   https://en.wikipedia.org/wiki/Euler%27s_totient_function\n#   https://github.com/danaj/Math-Prime-Util/blob/master/examples/inverse_totient.pl\n\nsub inverse_euler_phi {\n    my ($n) = @_;\n\n    my %r = (1 => [1]);\n\n    foreach my $d (divisors($n)) {\n\n        is_prime($d + 1) || next;\n\n        my %temp;\n        foreach my $k (1 .. (valuation($n, $d + 1) + 1)) {\n\n            my $u = $d * ($d + 1)**($k - 1);\n            my $v = ($d + 1)**$k;\n\n            foreach my $f (divisors($n / $u)) {\n                if (exists $r{$f}) {\n                    push @{$temp{$f * $u}}, map { $v * $_ } @{$r{$f}};\n                }\n            }\n        }\n\n        while (my ($i, $v) = each(%temp)) {\n            push @{$r{$i}}, @$v;\n        }\n    }\n\n    return if not exists $r{$n};\n    return sort { $a <=> $b } @{$r{$n}};\n}\n\nforeach my $n(1..70) {\n    if (my @inv = inverse_euler_phi($n)) {\n        say \"φ−¹($n) = [\", join(', ', @inv), \"]\";\n    }\n}\n"
  },
  {
    "path": "Math/inverse_of_factorial.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 18 July 2016\n# Edit: 23 October 2017\n# https://github.com/trizen\n\n# Compute the inverse of n-factorial.\n# The function is defined only for factorial numbers.\n# It may return non-sense for non-factorials.\n\n# See also:\n#   https://oeis.org/A090368\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(valuation factor factorial);\n\nsub factorial_prime_pow ($n, $p) {\n\n    my $count = 0;\n    my $ppow  = $p;\n\n    while ($ppow <= $n) {\n        $count += int($n / $ppow);\n        $ppow *= $p;\n    }\n\n    return $count;\n}\n\nsub p_adic_inverse ($p, $k) {\n\n    my $n = $k * ($p - 1);\n    while (factorial_prime_pow($n, $p) < $k) {\n        $n -= $n % $p;\n        $n += $p;\n    }\n\n    return $n;\n}\n\nsub inverse_of_factorial ($f) {\n\n    return 1 if $f == 1;\n\n    my $t = valuation($f, 2);         # largest power of 2 in f\n    my $z = p_adic_inverse(2, $t);    # smallest number z such that 2^t divides z!\n    my $d = (factor($z + 1))[-1];     # largest factor of z+1\n\n    if (valuation($f, $d) != factorial_prime_pow($z + 1, $d)) {\n        return $z;\n    }\n\n    return $z + 1;\n}\n\nforeach my $n (1 .. 30) {\n\n    my $f = factorial($n);\n    my $i = inverse_of_factorial($f);\n\n    say \"$i! = $f\";\n\n    if ($i != $n) {\n        die \"error: $i != $n\";\n    }\n}\n"
  },
  {
    "path": "Math/inverse_of_factorial_stirling.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 18 September 2016\n# Website: https://github.com/trizen\n\n# The inverse of n factorial, based on the inverse of Stirling approximation.\n\n# Formula from:\n#   https://math.stackexchange.com/questions/430167/is-there-an-inverse-to-stirlings-approximation\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload tau e factorial);\n\nuse constant S => tau->sqrt->log;\nuse constant T => tau->root(-2.0 * e);\n\nsub inverse_factorial_W {\n    my ($n) = @_;\n    my $L = log($n) - S;\n    $L / ($L / e)->LambertW - 0.5;\n}\n\nsub inverse_factorial_lgrt {\n    my ($n) = @_;\n    (T * $n**(1 / e))->lgrt * e - 0.5;\n}\n\nfor my $n (1 .. 100) {\n\n    my $f = factorial($n);\n    my $i = inverse_factorial_W($f);\n    my $j = inverse_factorial_lgrt($f);\n\n    printf(\"F(%2s!) =~ %s\\n\", $n, $i);\n\n    if ($i->round(-20) != $j->round(-20)) {\n        die \"$i != $j\";\n    }\n\n    if ($i->round != $n) {\n        die \"However that is incorrect! (expected: $n -- got \", $i->round, \")\";\n    }\n}\n"
  },
  {
    "path": "Math/inverse_of_fibonacci.pl",
    "content": "#!/usr/bin/perl\n\n# Find the position of a Fibonacci number in the Fibonacci sequence.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Fibonacci_number#Recognizing_Fibonacci_numbers\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload fibonacci is_square isqrt phi);\n\nsub fibonacci_inverse ($n) {\n\n    my $m = 5 * $n * $n;\n\n    if (is_square($m - 4)) {\n        $m = isqrt($m - 4);\n    }\n    elsif (is_square($m + 4)) {\n        $m = isqrt($m + 4);\n    }\n    else {\n        return -1;    # not a Fibonacci number\n    }\n\n    log(($n * sqrt(5) + $m) / 2) / log(phi);\n}\n\nsay fibonacci_inverse(fibonacci(100));    #=> 100\nsay fibonacci_inverse(fibonacci(101));    #=> 101\n"
  },
  {
    "path": "Math/inverse_of_multiplicative_functions.pl",
    "content": "#!/usr/bin/perl\n\n# Computing the inverse of some multiplicative functions.\n# Translation of invphi.gp ver. 2.1 by Max Alekseyev.\n\n# See also:\n#   https://home.gwu.edu/~maxal/gpscripts/\n\nuse utf8;\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory      qw(:all);\nuse experimental qw(signatures);\n\nsub dynamicPreimage ($N, $L, %opt) {\n\n    # Phase 1: Determine which intermediate values are actually needed\n    my %needed = ($N => undef);\n    my @operations;\n\n    foreach my $l (@$L) {\n        my @current_ops;\n\n        foreach my $pair (@$l) {\n            my ($x, $y) = @$pair;\n\n            foreach my $d (divisors(divint($N, $x))) {\n                my $F = mulint($x, $d);\n\n                # Only track operations that lead to needed values\n                if (exists $needed{$F}) {\n                    undef $needed{$d};\n                    push @current_ops, [$d, $y, $F];\n                }\n            }\n        }\n        unshift @operations, \\@current_ops if @current_ops;\n    }\n\n    undef %needed;\n\n    # Phase 2: Process operations, keeping only needed intermediate results\n    my %r = (1 => [1]);\n\n    foreach my $ops (@operations) {\n        my %t;\n\n        foreach my $op (@$ops) {\n            my ($d, $y, $F) = @$op;\n\n            if (exists $r{$d}) {\n                my @list = @{$r{$d}};\n                if ($opt{unitary}) {\n                    @list = grep { gcd($_, $y) == 1 } @list;\n                }\n                push @{$t{$F}}, map { mulint($_, $y) } @list;\n            }\n        }\n\n        while (my ($k, $v) = each %t) {\n            push @{$r{$k}}, @$v;\n        }\n    }\n\n    return if !exists $r{$N};\n    sort { $a <=> $b } @{$r{$N}};\n}\n\nsub dynamicLen ($N, $L) {\n\n    my %r = (1 => 1);\n\n    foreach my $l (@$L) {\n        my %t;\n\n        foreach my $pair (@$l) {\n            my ($x, $y) = @$pair;\n\n            foreach my $d (divisors(divint($N, $x))) {\n                if (exists $r{$d}) {\n                    $t{mulint($x, $d)} += $r{$d};\n                }\n            }\n        }\n        while (my ($k, $v) = each %t) {\n            $r{$k} += $v;\n        }\n    }\n\n    $r{$N} // 0;\n}\n\nsub dynamicMin ($N, $L) {\n\n    my %r = (1 => 1);\n\n    foreach my $l (@$L) {\n        my %t;\n\n        foreach my $pair (@$l) {\n            my ($x, $y) = @$pair;\n\n            foreach my $d (divisors(divint($N, $x))) {\n                if (exists $r{$d}) {\n\n                    my $k = mulint($x, $d);\n                    my $v = mulint($r{$d}, $y);\n\n                    if (not defined($t{$k})) {\n                        $t{$k} = $v;\n                    }\n                    else {\n                        $t{$k} = $v if ($v < $t{$k});\n                    }\n                }\n            }\n        }\n        while (my ($k, $v) = each %t) {\n            if (not defined($r{$k})) {\n                $r{$k} = $v;\n            }\n            else {\n                $r{$k} = $v if ($v < $r{$k});\n            }\n        }\n    }\n\n    $r{$N};\n}\n\nsub dynamicMax ($N, $L) {\n\n    my %r = (1 => 1);\n\n    foreach my $l (@$L) {\n        my %t;\n\n        foreach my $pair (@$l) {\n            my ($x, $y) = @$pair;\n\n            foreach my $d (divisors(divint($N, $x))) {\n                if (exists $r{$d}) {\n\n                    my $k = mulint($x, $d);\n                    my $v = mulint($r{$d}, $y);\n\n                    if (not defined($t{$k})) {\n                        $t{$k} = $v;\n                    }\n                    else {\n                        $t{$k} = $v if ($v > $t{$k});\n                    }\n                }\n            }\n        }\n        while (my ($k, $v) = each %t) {\n            if (not defined($r{$k})) {\n                $r{$k} = $v;\n            }\n            else {\n                $r{$k} = $v if ($v > $r{$k});\n            }\n        }\n    }\n\n    $r{$N};\n}\n\nsub cook_sigma ($N, $k) {\n    my %L;\n\n    foreach my $d (divisors($N)) {\n\n        next if ($d == 1);\n\n        foreach my $p (map { $_->[0] } factor_exp(subint($d, 1))) {\n\n            my $q = addint(mulint($d, subint(powint($p, $k), 1)), 1);\n            my $t = valuation($q, $p);\n\n            next if ($t <= $k or ($t % $k) or $q != powint($p, $t));\n\n            push @{$L{$p}}, [$d, powint($p, subint(divint($t, $k), 1))];\n        }\n    }\n\n    [values %L];\n}\n\nsub cook_phi ($N) {\n    my %L;\n\n    foreach my $d (divisors($N)) {\n        my $p = addint($d, 1);\n        is_prime($p) || next;\n        my $v = valuation($N, $p);\n        push @{$L{$p}}, map { [mulint($d, powint($p, $_ - 1)), powint($p, $_)] } 1 .. $v + 1;\n    }\n\n    [values %L];\n}\n\nsub cook_psi ($N) {\n    my %L;\n\n    foreach my $d (divisors($N)) {\n        my $p = subint($d, 1);\n        is_prime($p) || next;\n        my $v = valuation($N, $p);\n        push @{$L{$p}}, map { [mulint($d, powint($p, $_ - 1)), powint($p, $_)] } 1 .. $v + 1;\n    }\n\n    [values %L];\n}\n\nsub cook_usigma ($N) {\n    my @list;\n    foreach my $d (divisors($N)) {\n        if (is_prime_power(subint($d, 1))) {\n            push @list, [[$d, subint($d, 1)]];\n        }\n    }\n    return \\@list;\n}\n\nsub cook_uphi ($N) {\n    my @list;\n    foreach my $d (divisors($N)) {\n        if (is_prime_power(addint($d, 1))) {\n            push @list, [[$d, addint($d, 1)]];\n        }\n    }\n    return \\@list;\n}\n\n# Inverse of sigma function\n\nsub inverse_sigma ($N, $k = 1) {\n    dynamicPreimage($N, cook_sigma($N, $k));\n}\n\nsub inverse_sigma_min ($N, $k = 1) {\n    dynamicMin($N, cook_sigma($N, $k));\n}\n\nsub inverse_sigma_max ($N, $k = 1) {\n    dynamicMax($N, cook_sigma($N, $k));\n}\n\nsub inverse_sigma_len ($N, $k = 1) {\n    dynamicLen($N, cook_sigma($N, $k));\n}\n\n# Inverse of Euler phi function\n\nsub inverse_phi ($N) {\n    dynamicPreimage($N, cook_phi($N));\n}\n\nsub inverse_phi_min ($N) {\n    dynamicMin($N, cook_phi($N));\n}\n\nsub inverse_phi_max ($N) {\n    dynamicMax($N, cook_phi($N));\n}\n\nsub inverse_phi_len ($N) {\n    dynamicLen($N, cook_phi($N));\n}\n\n# Inverse of Dedekind psi function\n\nsub inverse_psi ($N) {\n    dynamicPreimage($N, cook_psi($N));\n}\n\nsub inverse_psi_min ($N) {\n    dynamicMin($N, cook_psi($N));\n}\n\nsub inverse_psi_max ($N) {\n    dynamicMax($N, cook_psi($N));\n}\n\nsub inverse_psi_len ($N) {\n    dynamicLen($N, cook_psi($N));\n}\n\n# Inverse of unitary sigma function\n\nsub inverse_usigma ($N) {\n    dynamicPreimage($N, cook_usigma($N), unitary => 1);\n}\n\n# Inverse of unitary phi function\n\nsub inverse_uphi ($N) {\n    dynamicPreimage($N, cook_uphi($N), unitary => 1);\n}\n\n## Usage example\n\nsay join ', ', inverse_sigma(120);         #=> [54, 56, 87, 95]\nsay join ', ', inverse_usigma(120);        #=> [60, 87, 92, 95, 99]\nsay join ', ', inverse_uphi(120);          #=> [121, 143, 144, 155, 164, 183, 220, 231, 240, 242, 286, 310, 366, 462]\nsay join ', ', inverse_phi(120);           #=> [143, 155, 175, 183, 225, 231, 244, 248, 286, 308, 310, 350, 366, 372, 396, 450, 462]\nsay join ', ', inverse_psi(120);           #=> [75, 76, 87, 95]\nsay join ', ', inverse_sigma(22100, 2);    #=> [120, 130, 141]\n\nsay '';\n\nsay inverse_sigma_min(factorial(10));      #=> 876960\nsay inverse_sigma_max(factorial(10));      #=> 3624941\nsay inverse_sigma_len(factorial(10));      #=> 1195\n\nsay '';\n\nsay inverse_phi_min(factorial(10));        #=> 3632617\nsay inverse_phi_max(factorial(10));        #=> 19969950\nsay inverse_phi_len(factorial(10));        #=> 3802\n\nsay '';\n\nsay inverse_psi_min(factorial(10));        #=> 1160250\nsay inverse_psi_max(factorial(10));        #=> 3624941\nsay inverse_psi_len(factorial(10));        #=> 1793\n\nsay '';\n"
  },
  {
    "path": "Math/inverse_of_p_adic_valuation.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 18 September 2017\n# https://github.com/trizen\n\n# Find the smallest number `n` such that `n!` has at least `k` factors of prime `p`.\n\n# See also:\n#   https://projecteuler.net/problem=320\n#   https://en.wikipedia.org/wiki/Legendre%27s_formula\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(vecsum todigits);\n\nsub factorial_power ($n, $p) {\n    ($n - vecsum(todigits($n, $p))) / ($p - 1);\n}\n\nsub p_adic_inverse ($p, $k) {\n\n    my $n = $k * ($p - 1);\n    while (factorial_power($n, $p) < $k) {\n        $n -= $n % $p;\n        $n += $p;\n    }\n\n    return $n;\n}\n\nsay p_adic_inverse(2,  100);           #=> 104\nsay p_adic_inverse(3,  51);            #=> 108\nsay p_adic_inverse(2,  992);           #=> 1000\nsay p_adic_inverse(13, 83333329);      #=> 999999988\nsay p_adic_inverse(97, 1234567890);    #=> 118518517733\n\nsay factorial_power(p_adic_inverse(7,  1234567890), 7);     #=> 1234567890\nsay factorial_power(p_adic_inverse(23, 1234567890), 23);    #=> 1234567890\nsay factorial_power(p_adic_inverse(97, 1234567890), 97);    #=> 1234567890\n"
  },
  {
    "path": "Math/inverse_of_sigma_function.pl",
    "content": "#!/usr/bin/perl\n\n# Given a positive integer `n`, this algorithm finds all the numbers k\n# such that sigma(k) = n, where `sigma(k)` is the sum of divisors of `k`.\n\n# Based on \"invphi.gp\" code by Max Alekseyev.\n\n# See also:\n#   https://home.gwu.edu/~maxal/gpscripts/\n\nuse utf8;\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\nuse List::Util qw(uniq);\n#use Math::AnyNum qw(:overload);\n\nbinmode(STDOUT, ':utf8');\n\nsub inverse_sigma ($n, $m = 3) {\n\n    return (1) if ($n == 1);\n\n    my @R;\n    foreach my $d (grep { $_ >= $m } divisors($n)) {\n        foreach my $p (map { $_->[0] } factor_exp($d - 1)) {\n            my $P = $d * ($p - 1) + 1;\n            my $k = valuation($P, $p) - 1;\n            next if (($k < 1) || ($P != $p**($k + 1)));\n            push @R, map { $_ * $p**$k } grep { $_ % $p != 0; } __SUB__->($n/$d, $d);\n        }\n    }\n\n    sort { $a <=> $b } uniq(@R);\n}\n\nforeach my $n (1 .. 70) {\n    (my @inv = inverse_sigma($n)) || next;\n    say \"σ−¹($n) = [\", join(', ', @inv), ']';\n}\n\n__END__\nσ−¹(1) = [1]\nσ−¹(3) = [2]\nσ−¹(4) = [3]\nσ−¹(6) = [5]\nσ−¹(7) = [4]\nσ−¹(8) = [7]\nσ−¹(12) = [6, 11]\nσ−¹(13) = [9]\nσ−¹(14) = [13]\nσ−¹(15) = [8]\nσ−¹(18) = [10, 17]\nσ−¹(20) = [19]\nσ−¹(24) = [14, 15, 23]\nσ−¹(28) = [12]\nσ−¹(30) = [29]\nσ−¹(31) = [16, 25]\nσ−¹(32) = [21, 31]\nσ−¹(36) = [22]\nσ−¹(38) = [37]\nσ−¹(39) = [18]\nσ−¹(40) = [27]\nσ−¹(42) = [26, 20, 41]\nσ−¹(44) = [43]\nσ−¹(48) = [33, 35, 47]\n"
  },
  {
    "path": "Math/inverse_of_sigma_function_fast.pl",
    "content": "#!/usr/bin/perl\n\n# Given a positive integer `n`, this algorithm finds all the numbers k\n# such that sigma(k) = n, where `sigma(k)` is the sum of divisors of `k`.\n\n# Based on \"invphi.gp\" code by Max Alekseyev.\n\n# See also:\n#   https://home.gwu.edu/~maxal/gpscripts/\n\nuse utf8;\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::Prime::Util::GMP qw(:all);\nuse List::Util qw(uniq);\nuse experimental qw(signatures);\n\nbinmode(STDOUT, ':utf8');\n\nsub inverse_sigma {\n    my ($n) = @_;\n\n    my %cache;\n    my %factor_cache;\n    my %divisor_cache;\n\n    my $results = sub ($n, $m) {\n\n        return [1] if ($n == 1);\n\n        my $key = \"$n $m\";\n        if (exists $cache{$key}) {\n            return $cache{$key};\n        }\n\n        my (@R, @D);\n        $divisor_cache{$n} //= [divisors($n)];\n\n        foreach my $d (@{$divisor_cache{$n}}) {\n            if ($d >= $m) {\n\n                push @D, $d;\n\n                $factor_cache{$d} //= do {\n                    my %factors;\n                    @factors{factor(subint($D[-1], 1))} = ();\n                    [keys %factors];\n                };\n            }\n        }\n\n        foreach my $d (@D) {\n            foreach my $p (@{$factor_cache{$d}}) {\n\n                my $r = addint(mulint($d, subint($p, 1)), 1);\n                my $k = valuation($r, $p) - 1;\n                next if ($k < 1);\n\n                my $s = powint($p, $k + 1);\n                next if (\"$r\" ne \"$s\");\n                my $z = powint($p, $k);\n\n                my $u   = divint($n, $d);\n                my $arr = __SUB__->($u, $d);\n\n                foreach my $v (@$arr) {\n                    if (modint($v, $p) != 0) {\n                        push @R, mulint($v, $z);\n                    }\n                }\n            }\n        }\n\n        $cache{$key} = \\@R;\n    }->($n, 3);\n\n    sort { $a <=> $b } uniq(@$results);\n}\n\nmy %tests = (\n     6 => 6187272, 10 => 196602,  11 => 8105688, 16 => 2031554,\n    25 => 1355816, 31 => 8880128, 80 => 11532,   97 => 5488,\n);\n\nwhile (my ($n, $k) = each %tests) {\n    my @inverse = inverse_sigma($k);\n    say \"σ−¹($k) = [@inverse]\";\n    if (gcd(@inverse) != $n) {\n        die \"Error for k = $k\";\n    }\n}\n\nuse Test::More;\nplan tests => 4;\n\nis(join(' ', inverse_sigma(42)), join(' ', 20, 26, 41));\nis(join(' ', inverse_sigma(7688)), join(' ', 2800, 2928, 4575, 7687));\nis(join(' ', inverse_sigma(\"110680464442257309690\")), \"46116860184273879040\");\nis(join(' ', inverse_sigma(\"9325257382230393314439814176\")), \"3535399776779654608221686964 4302950338161146561477374638 4637009852153025247015401018 4661529533007908774933879778 4884658628787348878992283572 5187814889839710566412258045 5311639278156872382400698772 5326520187917077557965023252 5328493035801953244119300732 5495240957385767488866317781 6208298641832871739558373002 6411114450283395403677372213 6417519160023938256228496989 6454455748546107757077838269 6799666841209661791779031135 6938435552254756930386764875 6992294299511863162400845113 7215972974344947207602237095 8501184728947212952861568533 8546137477181166087378779593 9130981186767260120388984667 9214242413394317203553625829 9323102747899933426890262757 9325091641128050246166715829 9325201015147968294835238387\");\n\n__END__\nσ−¹(6187272) = [2855646 2651676]\nσ−¹(196602) = [105650 81920]\nσ−¹(8105688) = [4953454 4947723]\nσ−¹(2031554) = [845200 999424]\nσ−¹(8880128) = [6389751 7527079]\nσ−¹(5488) = [3783 2716]\nσ−¹(11532) = [4880 4400]\nσ−¹(1355816) = [457500 390000 811875 624700]\n"
  },
  {
    "path": "Math/inverse_of_sigma_function_generalized.pl",
    "content": "#!/usr/bin/perl\n\n# Computing the inverse of the sigma_k(n) function, for any k >= 1.\n# Translation of invphi.gp ver. 2.1 by Max Alekseyev.\n\n# See also:\n#   https://home.gwu.edu/~maxal/gpscripts/\n\nuse utf8;\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub dynamicPreimage ($N, $L) {\n\n    my %r = (1 => [1]);\n\n    foreach my $l (@$L) {\n        my %t;\n\n        foreach my $pair (@$l) {\n            my ($x, $y) = @$pair;\n\n            foreach my $d (divisors(divint($N, $x))) {\n                if (exists $r{$d}) {\n                    push @{$t{mulint($x, $d)}}, map { mulint($_, $y) } @{$r{$d}};\n                }\n            }\n        }\n        while (my ($k, $v) = each %t) {\n            push @{$r{$k}}, @$v;\n        }\n    }\n\n    return if !exists $r{$N};\n    sort { $a <=> $b } @{$r{$N}};\n}\n\nsub cook_sigma ($N, $k) {\n    my %L;\n\n    foreach my $d (divisors($N)) {\n\n        next if ($d == 1);\n\n        foreach my $p (map { $_->[0] } factor_exp(subint($d, 1))) {\n\n            my $q = addint(mulint($d, subint(powint($p, $k), 1)), 1);\n            my $t = valuation($q, $p);\n\n            next if ($t <= $k or ($t % $k) or $q != powint($p, $t));\n\n            push @{$L{$p}}, [$d, powint($p, subint(divint($t, $k), 1))];\n        }\n    }\n\n    [values %L];\n}\n\nsub inverse_sigma ($N, $k = 1) {\n    dynamicPreimage($N, cook_sigma($N, $k));\n}\n\nsay join ', ', inverse_sigma(120);         #=> [54, 56, 87, 95]\nsay join ', ', inverse_sigma(22100, 2);    #=> [120, 130, 141]\n"
  },
  {
    "path": "Math/inverse_of_usigma_function.pl",
    "content": "#!/usr/bin/perl\n\n# Given a positive integer `n`, this algorithm finds all the numbers k\n# such that usigma(k) = n, where `usigma(k)` is the sum of the unitary divisors of `k`.\n\n# usigma(n) is multiplicative with usigma(p^k) = p^k + 1.\n\n# See also:\n#   https://oeis.org/A034448 -- usigma(n)\n#   https://home.gwu.edu/~maxal/gpscripts/\n\nuse utf8;\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub inverse_usigma ($n) {\n\n    my %r = (1 => [1]);\n\n    foreach my $d (divisors($n)) {\n\n        my $D = subint($d, 1);\n        is_prime_power($D) || next;\n\n        my %temp;\n\n        foreach my $f (divisors(divint($n, $d))) {\n            if (exists $r{$f}) {\n                push @{$temp{mulint($f, $d)}}, map { mulint($D, $_) }\n                  grep { gcd($D, $_) == 1 } @{$r{$f}};\n            }\n        }\n\n        while (my ($key, $value) = each(%temp)) {\n            push @{$r{$key}}, @$value;\n        }\n    }\n\n    return if not exists $r{$n};\n    return sort { $a <=> $b } @{$r{$n}};\n}\n\nmy $n = 186960;\n\nsay \"Solutions for usigma(x) = $n: \", join(' ', inverse_usigma($n));\n\n__END__\nSolutions for usigma(x) = 186960: 90798 108558 109046 113886 116835 120620 123518 123554 130844 131868 136419 138651 145484 148004 153495 155795 163503 163583 165771 166463 173907 174899 176823 179147 182003 185579 186089 186959\n"
  },
  {
    "path": "Math/inverse_tau_in_range.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 14 May 2026\n# https://github.com/trizen\n\n# Generate all the numbers in a given range [A,B] that have exactly `n` divisors.\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\n\nsub rootint_ceil($n, $k) {\n    rootint($n, $k) + (is_power($n, $k) ? 0 : 1);\n}\n\nsub unique_permutations($array, $callback) {\n    sub ($items, $current_perm) {\n\n        if (!@$items) {\n            $callback->($current_perm);\n            return;\n        }\n\n        my %level_seen;\n        for my $i (0 .. $#$items) {\n            my $item = $items->[$i];\n\n            # Skip iterations for duplicate elements in the same level\n            next if $level_seen{$item}++;\n\n            my @new_items = @$items;\n            splice(@new_items, $i, 1);\n\n            my @new_perm = (@$current_perm, $item);\n            __SUB__->(\\@new_items, \\@new_perm);\n        }\n    }->($array, []);\n}\n\nsub prime_signature_numbers_in_range($A, $B, $prime_signature) {\n\n    my @list;\n    my $k = scalar(@$prime_signature);\n\n    if ($k == 0) {\n        push(@list, 1) if ($A <= 1 and 1 <= $B);\n        return @list;\n    }\n\n    # The smallest possible number with k distinct prime factors\n    $A = vecmax(pn_primorial($k), $A);\n\n    my $generate = sub ($m, $lo, $k, $P, $sum_e) {\n\n        my $e  = $P->[$k - 1];\n        my $hi = rootint(divint($B, $m), $sum_e);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        # Base case\n        if ($k == 1) {\n\n            # Tighten the lower bound based on A\n            my $lo_tight = vecmax($lo, rootint_ceil(cdivint($A, $m), $e));\n\n            foreach my $p (@{primes($lo_tight, $hi)}) {\n                push @list, mulint($m, powint($p, $e));\n            }\n\n            return;\n        }\n\n        for (my $p = $lo ; $p <= $hi ;) {\n            my $t = mulint($m, powint($p, $e));\n            my $r = next_prime($p);\n            __SUB__->($t, $r, $k - 1, $P, $sum_e - $e);\n            $p = $r;\n        }\n    };\n\n    my $sum_e = vecsum(@$prime_signature) || return;\n\n    if ($sum_e > logint($B, 2)) {\n        return;\n    }\n\n    unique_permutations(\n        $prime_signature,\n        sub ($perm) {\n            $generate->(1, 2, scalar(@$perm), $perm, $sum_e);\n        }\n    );\n\n    return @list;\n}\n\nsub multiplicative_partitions($n, $max_value = $n) {\n\n    my @results;\n    my @divs = divisors($n);\n\n    shift(@divs);   # remove divisor '1'\n\n    my $end = $#divs;\n    sub ($target, $min_idx, $path) {\n\n        if ($target == 1) {\n            push @results, $path;\n            return;\n        }\n\n        for my $i ($min_idx .. $end) {\n            my $d = $divs[$i];\n\n            # Prune branch if the divisor exceeds the remaining target\n            last if $d > $target;\n            last if $d > $max_value;\n\n            if ($target % $d == 0) {\n                __SUB__->(divint($target, $d), $i, [@$path, $d]);\n            }\n        }\n    }->($n, 0, []);\n\n    return @results;\n}\n\nsub inverse_tau($A, $B, $n) {\n\n    my @signatures = map {\n        [map { $_ - 1 } @$_]\n    } multiplicative_partitions($n, logint($B, 2) + 1);\n\n    my @list;\n    foreach my $sig (@signatures) {\n        push @list, prime_signature_numbers_in_range($A, $B, $sig);\n    }\n\n    @list = sort { $a <=> $b } @list;\n\n    return @list;\n}\n\nscalar(inverse_tau(1, 462, 16)) == 16 or die \"error\";\nscalar(inverse_tau(1, powint(2, 9), 10)) == 13 or die \"error\";\nscalar(inverse_tau(1, powint(2, 40), 5040)) == 103 or die \"error\";\n\nmy @arr = inverse_tau(1e5, 1e5 + 500, 48);\nsay \"@arr\";    #=> 100050 100128 100152 100200 100254 100296 100380 100386 100485 100500\n"
  },
  {
    "path": "Math/invert_transform_of_factorials.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 03 December 2017\n# https://github.com/trizen\n\n# A new algorithm for computing the invert transform of factorial numbers.\n\n# See also:\n#   https://oeis.org/A051296\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload factorial binomial);\n\nsub invert_transform_of_factorials {\n    my ($n) = @_;\n\n    my @F = (1);\n\n    foreach my $i (1 .. $n) {\n        foreach my $k (0 .. $i - 1) {\n            $F[$i] += $F[$k] / binomial($i, $k);\n        }\n    }\n\n    map { $F[$_] * factorial($_) } 0 .. $#F;\n}\n\nmy @F = invert_transform_of_factorials(20);\n\nforeach my $i (0 .. $#F) {\n    say \"F($i) = $F[$i]\";\n}\n\n__END__\nF(0) = 1\nF(1) = 1\nF(2) = 3\nF(3) = 11\nF(4) = 47\nF(5) = 231\nF(6) = 1303\nF(7) = 8431\nF(8) = 62391\nF(9) = 524495\nF(10) = 4960775\nF(11) = 52223775\nF(12) = 605595319\nF(13) = 7664578639\nF(14) = 105046841127\nF(15) = 1548880173119\nF(16) = 24434511267863\nF(17) = 410503693136559\nF(18) = 7315133279097607\nF(19) = 137787834979031839\nF(20) = 2734998201208351479\n"
  },
  {
    "path": "Math/is_absolute_euler_pseudoprime.pl",
    "content": "#!/usr/bin/perl\n\n# Check if a given number is an absolute Euler pseudoprime.\n\n# These are composite n such that abs(a^((n-1)/2) mod n) = 1 for all a with gcd(a,n) = 1.\n\n# See also:\n#   https://oeis.org/A033181 -- Absolute Euler pseudoprimes\n#   https://en.wikipedia.org/wiki/Euler_pseudoprime\n\nuse 5.014;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub is_absolute_euler_pseudoprime ($n) {\n    is_carmichael($n)\n        and vecall { (($n-1)>>1) % ($_-1) == 0 } factor($n);\n}\n\nforoddcomposites {\n    say $_ if is_absolute_euler_pseudoprime($_);\n} 1e6;\n"
  },
  {
    "path": "Math/is_almost_prime.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 February 2023\n# https://github.com/trizen\n\n# A simple and fast method for checking if a given integer n has exactly k prime factors (i.e.: bigomega(n) = k).\n\nuse 5.020;\nuse warnings;\n\nuse ntheory      qw(:all);\nuse experimental qw(signatures);\n\nuse Math::GMPz;\nuse Math::Prime::Util::GMP;\n\nuse constant {\n              TRIAL_LIMIT        => 1e3,\n              HAS_NEW_PRIME_UTIL => defined(&Math::Prime::Util::is_almost_prime),\n             };\n\nmy @SMALL_PRIMES = @{primes(TRIAL_LIMIT)};\n\nsub mpz_is_almost_prime ($n, $k) {\n\n    state $z = Math::GMPz::Rmpz_init();\n    state $t = Math::GMPz::Rmpz_init();\n\n    if ($n == 0) {\n        return 0;\n    }\n\n    Math::GMPz::Rmpz_set_str($z, \"$n\", 10);\n    Math::GMPz::Rmpz_root($t, $z, $k);\n\n    my $trial_limit = Math::GMPz::Rmpz_get_ui($t);\n\n    if ($trial_limit > TRIAL_LIMIT or !Math::GMPz::Rmpz_fits_ulong_p($t)) {\n        $trial_limit = TRIAL_LIMIT;\n    }\n\n    foreach my $p (@SMALL_PRIMES) {\n\n        last if ($p > $trial_limit);\n\n        if (Math::GMPz::Rmpz_divisible_ui_p($z, $p)) {\n            Math::GMPz::Rmpz_set_ui($t, $p);\n            $k -= Math::GMPz::Rmpz_remove($z, $z, $t);\n        }\n\n        ($k > 0) or last;\n\n        if (HAS_NEW_PRIME_UTIL and Math::GMPz::Rmpz_fits_ulong_p($z)) {\n            return Math::Prime::Util::is_almost_prime($k, Math::GMPz::Rmpz_get_ui($z));\n        }\n    }\n\n    if ($k < 0) {\n        return 0;\n    }\n\n    if (Math::GMPz::Rmpz_cmp_ui($z, 1) == 0) {\n        return ($k == 0);\n    }\n\n    if ($k == 0) {\n        return (Math::GMPz::Rmpz_cmp_ui($z, 1) == 0);\n    }\n\n    if ($k == 1) {\n\n        if (Math::GMPz::Rmpz_fits_ulong_p($z)) {\n            return is_prime(Math::GMPz::Rmpz_get_ui($z));\n        }\n\n        return Math::Prime::Util::GMP::is_prime(Math::GMPz::Rmpz_get_str($z, 10));\n    }\n\n    Math::GMPz::Rmpz_ui_pow_ui($t, next_prime($trial_limit), $k);\n\n    if (Math::GMPz::Rmpz_cmp($z, $t) < 0) {\n        return 0;\n    }\n\n    (HAS_NEW_PRIME_UTIL and Math::GMPz::Rmpz_fits_ulong_p($z))\n      ? Math::Prime::Util::is_almost_prime($k, Math::GMPz::Rmpz_get_ui($z))\n      : (factor(Math::GMPz::Rmpz_get_str($z, 10)) == $k);\n}\n\nforeach my $n (1 .. 100) {\n    my $t = urandomb($n) + 1;\n\n    say \"Testing: $t\";\n\n    foreach my $k (1 .. 20) {\n        if (HAS_NEW_PRIME_UTIL ? Math::Prime::Util::is_almost_prime($k, $t) : (factor($t) == $k)) {\n            mpz_is_almost_prime($t, $k) || die \"error for: ($t, $k)\";\n        }\n        elsif (mpz_is_almost_prime($t, $k)) {\n            die \"counter-example: ($t, $k)\";\n        }\n    }\n}\n"
  },
  {
    "path": "Math/is_bfsw_pseudoprime.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 31 October 2023\n# https://github.com/trizen\n\n# A new primality test, using only the Lucas V sequence.\n\n# This test is a simplification of the strengthen BPSW test:\n# https://arxiv.org/abs/2006.14425\n\nuse 5.036;\nuse Math::GMPz;\n\nuse constant {\n              USE_METHOD_A_STAR => 0,    # true to use the A* method in finding (P,Q)\n             };\n\nsub check_lucasV ($P, $Q, $m) {\n\n    state $t = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_add_ui($t, $m, 1);\n\n    my $s = Math::GMPz::Rmpz_scan1($t, 0);\n    Math::GMPz::Rmpz_div_2exp($t, $t, $s + 1);\n\n    my $V1 = Math::GMPz::Rmpz_init_set_ui(2);\n    my $V2 = Math::GMPz::Rmpz_init_set_ui($P);\n\n    my $Q1 = Math::GMPz::Rmpz_init_set_ui(1);\n    my $Q2 = Math::GMPz::Rmpz_init_set_ui(1);\n\n    foreach my $bit (split(//, Math::GMPz::Rmpz_get_str($t, 2))) {\n\n        Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);\n        Math::GMPz::Rmpz_mod($Q1, $Q1, $m);\n\n        if ($bit) {\n            Math::GMPz::Rmpz_mul_si($Q2, $Q1, $Q);\n            Math::GMPz::Rmpz_mul($V1, $V1, $V2);\n            Math::GMPz::Rmpz_powm_ui($V2, $V2, 2, $m);\n            Math::GMPz::Rmpz_submul_ui($V1, $Q1, $P);\n            Math::GMPz::Rmpz_submul_ui($V2, $Q2, 2);\n            Math::GMPz::Rmpz_mod($V1, $V1, $m);\n        }\n        else {\n            Math::GMPz::Rmpz_set($Q2, $Q1);\n            Math::GMPz::Rmpz_mul($V2, $V2, $V1);\n            Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $m);\n            Math::GMPz::Rmpz_submul_ui($V2, $Q1, $P);\n            Math::GMPz::Rmpz_submul_ui($V1, $Q2, 2);\n            Math::GMPz::Rmpz_mod($V2, $V2, $m);\n        }\n    }\n\n    Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);\n    Math::GMPz::Rmpz_mod($Q1, $Q1, $m);\n\n    Math::GMPz::Rmpz_mul_si($Q2, $Q1, $Q);\n    Math::GMPz::Rmpz_mul($V1, $V1, $V2);\n    Math::GMPz::Rmpz_submul_ui($V1, $Q1, $P);\n    Math::GMPz::Rmpz_mul($Q2, $Q2, $Q1);\n\n    for (1 .. $s) {\n        Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $m);\n        Math::GMPz::Rmpz_submul_ui($V1, $Q2, 2);\n        Math::GMPz::Rmpz_powm_ui($Q2, $Q2, 2, $m);\n    }\n\n    Math::GMPz::Rmpz_mod($V1, $V1, $m);\n\n    Math::GMPz::Rmpz_set_si($t, 2 * $Q);\n    Math::GMPz::Rmpz_congruent_p($V1, $t, $m) || return 0;\n\n    Math::GMPz::Rmpz_set_si($t, $Q * $Q);\n    Math::GMPz::Rmpz_congruent_p($Q2, $t, $m) || return 0;\n\n    return 1;\n}\n\nsub findQ ($n) {\n    for (my $k = 2 ; ; ++$k) {\n        my $D = (-1)**$k * (2 * $k + 1);\n\n        my $K = Math::GMPz::Rmpz_si_kronecker($D, $n);\n\n        if ($K == -1) {\n            return ((1 - $D) / 4);\n        }\n        elsif ($K == 0 and abs($D) < $n) {\n            return undef;\n        }\n        elsif ($k == 20 and Math::GMPz::Rmpz_perfect_square_p($n)) {\n            return undef;\n        }\n    }\n}\n\nsub findP ($n, $Q) {\n    for (my $P = 2 ; ; ++$P) {\n        my $D = $P * $P - 4 * $Q;\n\n        my $K = Math::GMPz::Rmpz_si_kronecker($D, $n);\n\n        if ($K == -1) {\n            return $P;\n        }\n        elsif ($K == 0 and abs($D) < $n) {\n            return undef;\n        }\n        elsif ($P == 20 and Math::GMPz::Rmpz_perfect_square_p($n)) {\n            return undef;\n        }\n    }\n}\n\nsub is_bfsw_psp ($n) {\n\n    $n = Math::GMPz::Rmpz_init_set_str($n, 10) if ref($n) ne 'Math::GMPz';\n\n    return 0 if Math::GMPz::Rmpz_cmp_ui($n, 1) <= 0;\n    return 1 if Math::GMPz::Rmpz_cmp_ui($n, 2) == 0;\n    return 0 if Math::GMPz::Rmpz_even_p($n);\n\n    my ($P, $Q);\n\n    if (USE_METHOD_A_STAR) {\n        $P = 1;\n        $Q = findQ($n) // return 0;\n\n        if ($Q == -1) {\n            $P = 5;\n            $Q = 5;\n        }\n    }\n    else {\n        $Q = -2;\n        $P = findP($n, $Q) // return 0;\n    }\n\n    check_lucasV($P, $Q, $n);\n}\n\nmy @strong_lucas_psp = (\n                        5459,   5777,   10877,  16109,  18971,  22499,  24569,  25199,  40309,  58519,  75077,  97439,\n                        100127, 113573, 115639, 130139, 155819, 158399, 161027, 162133, 176399, 176471, 189419, 192509,\n                        197801, 224369, 230691, 231703, 243629, 253259, 268349, 288919, 313499, 324899\n                       );\nmy @extra_strong_lucas_psp = (\n                              989,    3239,   5777,   10877,  27971,  29681,  30739,  31631,  39059,  72389,  73919,  75077,\n                              100127, 113573, 125249, 137549, 137801, 153931, 155819, 161027, 162133, 189419, 218321, 231703,\n                              249331, 370229, 429479, 430127, 459191, 473891, 480689, 600059, 621781, 632249, 635627\n                             );\n\nforeach my $n (913, 150267335403, 430558874533, 14760229232131, 936916995253453, @strong_lucas_psp, @extra_strong_lucas_psp) {\n    if (is_bfsw_psp($n)) {\n        say \"Counter-example: $n\";\n    }\n}\n\nuse ntheory qw(is_prime);\n\nmy $from  = 1;\nmy $to    = 1e5;\nmy $count = 0;\n\nforeach my $n ($from .. $to) {\n    if (is_bfsw_psp($n)) {\n        if (not is_prime($n)) {\n            say \"Counter-example: $n\";\n        }\n        ++$count;\n    }\n    elsif (is_prime($n)) {\n        say \"Missed a prime: $n\";\n    }\n}\n\nsay \"There are $count primes between $from and $to.\";\n\nis_bfsw_psp(3 * Math::GMPz->new(\"2\")**5134 - 1) or die \"error\";\nis_bfsw_psp(Math::GMPz->new(10)**2000 + 4561)   or die \"error\";\n\n__END__\nInspired by the paper \"Strengthening the Baillie-PSW primality test\", I propose a simplified test based on Lucas V-pseudoprimes, that requires computing only the Lucas V sequence, making it faster than the full BPSW test, while being about as strong.\n\nThe first observation was that none of the 5 vpsp terms < 10^15 satisfy:\n\nQ^(n+1) == Q^2 (mod n)\n\nThis gives us a simple test:\n\nV_{n+1}(P,Q) == 2*Q (mod n)\nQ^(n+1) == Q^2 (mod n)\n\nwhere (P,Q) are selected using Method A*.\n"
  },
  {
    "path": "Math/is_chernick_carmichael_number.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 21 July 2018\n# https://github.com/trizen\n\n# Efficient algorithm for factoring (and identifying) an extended Chernick-Carmichael number.\n\n# The first few extended Chernick-Carmichael numbers are:\n#   1729, 63973, 294409, 56052361, 118901521, 172947529, 216821881\n\n# See also:\n#   https://oeis.org/A317126\n#   https://projecteuclid.org/euclid.bams/1183501763\n#   https://oeis.org/wiki/Carmichael_numbers\n#   https://en.wikipedia.org/wiki/Carmichael_number\n\nuse 5.024;\nuse warnings;\nuse experimental qw(signatures);\n\nuse List::Util qw(all);\nuse ntheory qw(is_prob_prime);\nuse Math::AnyNum qw(bsearch iroot ipow2 ilog2 is_div prod);\n\nsub chernick_carmichael_factors ($k, $r) {\n    (6 * $k + 1, 12 * $k + 1, 18 * $k + 1, (map { ipow2($_ - 2) * 9 * $k + 1 } 4 .. $r));\n}\n\nsub is_chernick_number ($n) {\n\n    foreach my $r (3 .. ilog2($n)) {\n\n        return 0 if (prod(chernick_carmichael_factors(1, $r)) > $n);\n\n        my $k = bsearch(1, iroot($n, $r), sub {\n            prod(chernick_carmichael_factors($_, $r)) <=> $n;\n        });\n\n        if (defined($k)) {\n            if (all { is_prob_prime($_) } chernick_carmichael_factors($k, $r)) {\n                return [$r, $k];\n            }\n        }\n    }\n\n    return 0;\n}\n\nsub is_chernick_carmichael_number ($n) {\n    if (my $indices = is_chernick_number($n)) {\n        my ($r, $k) = @$indices;\n        is_div($k, Math::AnyNum->new(2)**($r-4)) || return 0;\n        return $indices;\n    }\n    return 0;\n}\n\nwhile (defined(my $n = <DATA>)) {\n\n    $n =~ /\\S/ or do { say ''; next };\n    $n = Math::AnyNum->new($n);\n\n    if (my $indices = is_chernick_number($n)) {\n        my ($r, $k) = @$indices;\n        say \"C($r, $k) = $n\" . (is_chernick_carmichael_number($n) ? '' : ' -- not a Carmichael number');\n    }\n    else {\n        say \"Not a Chernick-Carmichael number: $n\";\n    }\n}\n\n__DATA__\n8325544586081174440728309072452661246289\n1486602098904402652768057938393756060862115780408050129\n3378179316469672624194241840042044950902156938854178152235606615241\n499363105138762800665090830700779256789861194424677603719907844311565991734904219234049\n1052541934726120302251454117065809600311128515412938768050107822597914636735491079562159895572772335029969\n\n179888061095822220624012979873\n63295903488856146099776074891976628857941\n1724903525088632276776203991973751571437217198753\n125987992642689799129021757759222604492631818017403553\n74630998863011672833530378836051056508973606035192155974373\n150807169001103453136788769176330405141656863663445656308543366854744067292801145941\n21481148526108486207494916467772828869885661326738699922267375224852562302202790454088898856458273\n\n521635331852681575100906881\n115062400756082746082903913434881\n328163039680360319939589778453584981903661\n11870677991315757722817424115344135399200189518509\n694757711287970946444438020864958912321095838203403981194280844652135041\n222047766292417414109702829403660230521393563058846142752440148661965564062512001\n2149862240504463136613099818734059855038070454228745908492682225005023324481983560300180977379301646829\n8708697287275863064616447198348134859079135616902774104816953554105827536430199092250104748403143942843541581649\n837766669080429652091578576905732301415513036087717526534117797730213142822067681852966424142891732971385451048036269\n\n261398323061911176816691559756701\n3783580131711518790634677710442261470580569797344541\n435371627429039040724001132527124473123288702163349741876813423106621\n14719770617180585920139917829493719272506560558845969856660560241654606362030081\n8639174282669715206025361687559030161351650277392264712967444363592650828493196768893181\n5626560312723043583857755308221019825156276365042073078860543702210734827773374603314058575101\n\n24556868549786120178074590558386520603888321\n6039952244643618043250948311869286217356083814166356276064323543587107521\n67237835600056002507521755422513656134639570320064261052894337496662546902793661\n9812486963666228314195838164491424691687915196563926066688165613493816842244920774774301\n16734371894003494165203863331927626808333173646940855138811711887045893525137741919908066470621\n"
  },
  {
    "path": "Math/is_even_perfect.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 20 September 2016\n# Website: https://github.com/trizen\n\n# A very fast function that returns true when a given number is even-perfect. False otherwise.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Perfect_number\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload is_power isqrt);\nuse ntheory qw(is_mersenne_prime is_prime_power);\n\nsub is_even_perfect {\n    my ($n) = @_;\n\n    $n % 2 == 0 || return 0;\n\n    my $square = 8 * $n + 1;\n    is_power($square, 2) || return 0;\n\n    my $tp = (isqrt($square) + 1) / 2;\n    my $k = is_prime_power($tp, \\my $base) || return 0;\n\n    defined($base) && ($base == 2) && is_mersenne_prime($k) ? 1 : 0;\n}\n\nsay is_even_perfect(191561942608236107294793378084303638130997321548169216);                           # true\nsay is_even_perfect(191561942608236107294793378084303638130997321548169214);                           # false\nsay is_even_perfect(191561942608236107294793378084303638130997321548169218);                           # false\nsay is_even_perfect(14474011154664524427946373126085988481573677491474835889066354349131199152128);    # true\n\n# A much larger perfect number\nsay is_even_perfect(Math::AnyNum->new('141053783706712069063207958086063189881486743514715667838838675999954867742652380114104193329037690251561950568709829327164087724366370087116731268159313652487450652439805877296207297446723295166658228846926807786652870188920867879451478364569313922060370695064736073572378695176473055266826253284886383715072974324463835300053138429460296575143368065570759537328128'));\n\n# Search test\nsay \"=> Perfect numbers below 10^4:\";\nfor my $n (1 .. 10000) {\n    is_even_perfect($n) && say $n;\n}\n"
  },
  {
    "path": "Math/is_even_perfect_2.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 20 September 2016\n# Website: https://github.com/trizen\n\n# A very fast function that returns true when a given number is even-perfect. False otherwise.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Perfect_number\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload is_square isqrt valuation);\nuse ntheory qw(is_mersenne_prime);\n\nsub is_even_perfect {\n    my ($n) = @_;\n\n    $n % 2 == 0 || return 0;\n\n    my $square = 8 * $n + 1;\n    is_square($square) || return 0;\n\n    my $k = (isqrt($square) + 1) / 2;\n    ($k & ($k - 1)) == 0 && is_mersenne_prime(valuation($k, 2)) ? 1 : 0;\n}\n\nsay is_even_perfect(191561942608236107294793378084303638130997321548169216);                           # true\nsay is_even_perfect(191561942608236107294793378084303638130997321548169214);                           # false\nsay is_even_perfect(191561942608236107294793378084303638130997321548169218);                           # false\nsay is_even_perfect(14474011154664524427946373126085988481573677491474835889066354349131199152128);    # true\n\n# A much larger perfect number\nsay is_even_perfect(Math::AnyNum->new('141053783706712069063207958086063189881486743514715667838838675999954867742652380114104193329037690251561950568709829327164087724366370087116731268159313652487450652439805877296207297446723295166658228846926807786652870188920867879451478364569313922060370695064736073572378695176473055266826253284886383715072974324463835300053138429460296575143368065570759537328128'));\n\n# Search test\nsay \"=> Perfect numbers below 10^4:\";\nfor my $n (1 .. 10000) {\n    is_even_perfect($n) && say $n;\n}\n"
  },
  {
    "path": "Math/is_even_perfect_3.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 12 December 2016\n# https://github.com/trizen\n\n# An efficient verification for an even perfect number.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload valuation);\nuse ntheory qw(is_mersenne_prime);\n\nsub is_even_perfect {\n    my ($n) = @_;\n    my $v = valuation($n, 2) || return 0;\n    my $m = ($n >> $v);\n    ($m & ($m+1))            && return 0;\n    ($m >> $v) == 1          || return 0;\n    is_mersenne_prime($v+1);\n}\n\nsay is_even_perfect(191561942608236107294793378084303638130997321548169216);                           # true\nsay is_even_perfect(191561942608236107294793378084303638130997321548169214);                           # false\nsay is_even_perfect(191561942608236107294793378084303638130997321548169218);                           # false\nsay is_even_perfect(14474011154664524427946373126085988481573677491474835889066354349131199152128);    # true\n\n# A much larger perfect number\nsay is_even_perfect(Math::AnyNum->new('141053783706712069063207958086063189881486743514715667838838675999954867742652380114104193329037690251561950568709829327164087724366370087116731268159313652487450652439805877296207297446723295166658228846926807786652870188920867879451478364569313922060370695064736073572378695176473055266826253284886383715072974324463835300053138429460296575143368065570759537328128'));\n\n# Search test\nsay \"=> Perfect numbers below 10^4:\";\nfor my $n (1 .. 10000) {\n    is_even_perfect($n) && say $n;\n}\n"
  },
  {
    "path": "Math/is_extra_bfsw_pseudoprime.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 31 October 2023\n# https://github.com/trizen\n\n# A new primality test, using only the Lucas V sequence.\n\n# This test is a simplification of the strengthen BPSW test:\n# https://arxiv.org/abs/2006.14425\n\nuse 5.036;\nuse Math::GMPz;\n\nuse constant {\n              USE_METHOD_A_STAR => 0,    # true to use the A* method in finding (P,Q)\n             };\n\nsub partial_lucasVmod_pow2 ($P, $Q, $two_val, $m, $V1, $V2, $Q1, $Q2) {\n\n    Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);\n    Math::GMPz::Rmpz_mod($Q1, $Q1, $m);\n\n    Math::GMPz::Rmpz_mul_si($Q2, $Q1, $Q);\n    Math::GMPz::Rmpz_mul($V1, $V1, $V2);\n    Math::GMPz::Rmpz_submul_ui($V1, $Q1, $P);\n    Math::GMPz::Rmpz_mul($Q2, $Q2, $Q1);\n\n    for (1 .. $two_val) {\n        Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $m);\n        Math::GMPz::Rmpz_submul_ui($V1, $Q2, 2);\n        Math::GMPz::Rmpz_powm_ui($Q2, $Q2, 2, $m);\n    }\n\n    Math::GMPz::Rmpz_mod($V1, $V1, $m);\n    return ($V1, $Q2);\n}\n\nsub partial_lucasVmod ($P, $Q, $bits, $m, $V1 = undef, $V2 = undef, $Q1 = undef, $Q2 = undef) {\n\n    $V1 //= Math::GMPz::Rmpz_init_set_ui(2);\n    $V2 //= Math::GMPz::Rmpz_init_set_ui($P);\n\n    $Q1 //= Math::GMPz::Rmpz_init_set_ui(1);\n    $Q2 //= Math::GMPz::Rmpz_init_set_ui(1);\n\n    foreach my $bit (@$bits) {\n\n        Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);\n        Math::GMPz::Rmpz_mod($Q1, $Q1, $m);\n\n        if ($bit) {\n            Math::GMPz::Rmpz_mul_si($Q2, $Q1, $Q);\n            Math::GMPz::Rmpz_mul($V1, $V1, $V2);\n            Math::GMPz::Rmpz_powm_ui($V2, $V2, 2, $m);\n            Math::GMPz::Rmpz_submul_ui($V1, $Q1, $P);\n            Math::GMPz::Rmpz_submul_ui($V2, $Q2, 2);\n            Math::GMPz::Rmpz_mod($V1, $V1, $m);\n        }\n        else {\n            Math::GMPz::Rmpz_set($Q2, $Q1);\n            Math::GMPz::Rmpz_mul($V2, $V2, $V1);\n            Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $m);\n            Math::GMPz::Rmpz_submul_ui($V2, $Q1, $P);\n            Math::GMPz::Rmpz_submul_ui($V1, $Q2, 2);\n            Math::GMPz::Rmpz_mod($V2, $V2, $m);\n        }\n    }\n\n    Math::GMPz::Rmpz_mod($V1, $V1, $m);\n    return ($V1, $V2, $Q1, $Q2);\n}\n\nsub check_lucasV ($P, $Q, $m) {\n\n    state $t = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_add_ui($t, $m, 1);\n\n    my @b1 = split //, Math::GMPz::Rmpz_get_str($m, 2);\n    my @b2 = split //, Math::GMPz::Rmpz_get_str($t, 2);\n\n    my $k = 0;\n\n    if ($#b1 == $#b2) {\n        for my $i (0 .. $#b1) {\n            if ($b1[$i] != $b2[$i]) { $k = $i; last }\n        }\n    }\n\n    my @overlap = @b1[0 .. $k - 1];\n    my ($V1, $V2, $Q1, $Q2) = partial_lucasVmod($P, $Q, \\@overlap, $m);\n\n    my $two_val = $#b2 - $k;\n    my ($V1_a, $Q2_a) = partial_lucasVmod_pow2($P, $Q, $two_val, $m, map { Math::GMPz::Rmpz_init_set($_) } ($V1, $V2, $Q1, $Q2));\n\n    Math::GMPz::Rmpz_set_si($t, 2 * $Q);\n    Math::GMPz::Rmpz_congruent_p($V1_a, $t, $m) || return 0;\n\n    Math::GMPz::Rmpz_set_si($t, $Q * $Q);\n    Math::GMPz::Rmpz_congruent_p($Q2_a, $t, $m) || return 0;\n\n    my ($V1_b, undef, undef, $Q2_b) = partial_lucasVmod($P, $Q, [@b1[$k .. $#b1]], $m, $V1, $V2, $Q1, $Q2);\n\n    Math::GMPz::Rmpz_set_si($t, $P);\n    Math::GMPz::Rmpz_congruent_p($V1_b, $t, $m) || return 0;\n\n    Math::GMPz::Rmpz_set_si($t, Math::GMPz::Rmpz_si_kronecker($Q, $m) * $Q);\n    Math::GMPz::Rmpz_congruent_p($Q2_b, $t, $m) || return 0;\n\n    return 1;\n}\n\nsub findQ ($n) {\n    for (my $k = 2 ; ; ++$k) {\n        my $D = (-1)**$k * (2 * $k + 1);\n\n        my $K = Math::GMPz::Rmpz_si_kronecker($D, $n);\n\n        if ($K == -1) {\n            return ((1 - $D) / 4);\n        }\n        elsif ($K == 0 and abs($D) < $n) {\n            return undef;\n        }\n        elsif ($k == 20 and Math::GMPz::Rmpz_perfect_square_p($n)) {\n            return undef;\n        }\n    }\n}\n\nsub findP ($n, $Q) {\n    for (my $P = 2 ; ; ++$P) {\n        my $D = $P * $P - 4 * $Q;\n\n        my $K = Math::GMPz::Rmpz_si_kronecker($D, $n);\n\n        if ($K == -1) {\n            return $P;\n        }\n        elsif ($K == 0 and abs($D) < $n) {\n            return undef;\n        }\n        elsif ($P == 20 and Math::GMPz::Rmpz_perfect_square_p($n)) {\n            return undef;\n        }\n    }\n}\n\nsub is_extra_bfsw_psp ($n) {\n\n    $n = Math::GMPz::Rmpz_init_set_str($n, 10) if ref($n) ne 'Math::GMPz';\n\n    return 0 if Math::GMPz::Rmpz_cmp_ui($n, 1) <= 0;\n    return 1 if Math::GMPz::Rmpz_cmp_ui($n, 2) == 0;\n    return 0 if Math::GMPz::Rmpz_even_p($n);\n\n    my ($P, $Q);\n\n    if (USE_METHOD_A_STAR) {\n        $P = 1;\n        $Q = findQ($n) // return 0;\n\n        if ($Q == -1) {\n            $P = 5;\n            $Q = 5;\n        }\n    }\n    else {\n        $Q = -2;\n        $P = findP($n, $Q) // return 0;\n    }\n\n    check_lucasV($P, $Q, $n);\n}\n\nmy @strong_lucas_psp = (\n                        5459,   5777,   10877,  16109,  18971,  22499,  24569,  25199,  40309,  58519,  75077,  97439,\n                        100127, 113573, 115639, 130139, 155819, 158399, 161027, 162133, 176399, 176471, 189419, 192509,\n                        197801, 224369, 230691, 231703, 243629, 253259, 268349, 288919, 313499, 324899\n                       );\nmy @extra_strong_lucas_psp = (\n                              989,    3239,   5777,   10877,  27971,  29681,  30739,  31631,  39059,  72389,  73919,  75077,\n                              100127, 113573, 125249, 137549, 137801, 153931, 155819, 161027, 162133, 189419, 218321, 231703,\n                              249331, 370229, 429479, 430127, 459191, 473891, 480689, 600059, 621781, 632249, 635627\n                             );\n\nforeach my $n (913, 150267335403, 430558874533, 14760229232131, 936916995253453, @strong_lucas_psp, @extra_strong_lucas_psp) {\n    if (is_extra_bfsw_psp($n)) {\n        say \"Counter-example: $n\";\n    }\n}\n\nuse ntheory qw(is_prime);\n\nmy $from  = 1;\nmy $to    = 1e5;\nmy $count = 0;\n\nforeach my $n ($from .. $to) {\n    if (is_extra_bfsw_psp($n)) {\n        if (not is_prime($n)) {\n            say \"Counter-example: $n\";\n        }\n        ++$count;\n    }\n    elsif (is_prime($n)) {\n        say \"Missed a prime: $n\";\n    }\n}\n\nsay \"There are $count primes between $from and $to.\";\n\nis_extra_bfsw_psp(3 * Math::GMPz->new(\"2\")**5134 - 1) or die \"error\";\nis_extra_bfsw_psp(Math::GMPz->new(10)**2000 + 4561)   or die \"error\";\n\n__END__\nInspired by the paper \"Strengthening the Baillie-PSW primality test\", I propose a simplified test based on Lucas V-pseudoprimes, that requires computing only the Lucas V sequence, making it faster than the full BPSW test, while being about as strong.\n\nThe first observation was that none of the 5 vpsp terms < 10^15 satisfy:\n\nQ^(n+1) == Q^2 (mod n)\n\nThis gives us a simple test:\n\nV_{n+1}(P,Q) == 2*Q (mod n)\nQ^(n+1) == Q^2 (mod n)\n\nwhere (P,Q) are selected using Method A*.\n\nAt very little additional computational cost (on average), we can make the test even stronger, by also checking:\n\nV_n(P,Q) == P (mod n)\n\nNotice that also none of the 5 vpsp terms < 10^15 satisfy the above congruence.\n\nThe trick for computing V_n with very little additional computational cost (on average), is to compute the partial value of the Lucas V sequence, using the most significant overlapping bits of n and n+1.\n\nFirst we compute:\n\nV_d(P,Q) mod n\n\nwhere d is the \"most significant overlapping binary part\" of n and n+1.\n\nFor example, if n = 43, we have:\n\nn   = 101011_2\nn+1 = 101100_2\n\nThe most significant overlapping bits of n and n+1 are: \"101\", therefore d = 101_2 = 5.\n\nFrom V_d(P,Q) mod n, we compute V_{n+1}(P,Q) mod n, using the remaining bits of n+1: \"100\".\n\nNotice that the remaining bits of n+1 always form a power of two, allowing us to optimize the computation of V_{n+1}(P,Q) mod n.\n\nAt this stage, we check the necessary congruences trying to return early:\n\nV_{n+1}(P,Q) == 2*Q (mod n)\nQ^(n+1) == Q^2 (mod n)\n\nIf the number passed the above congruences, we compute V_n(P,Q) mod n from V_d(P,Q) mod n, using the remaining bits of n: \"011\", then we check:\n\nV_n(P,Q) == P (mod n)\nQ^((n+1)/2) == Q*(Q|n) (mod n)\n\nFinally, we return true if the number satisfied all the congruences, indicating that it is probably prime.\n\nThere are no known counter-examples to the presented test.\n\nRemarks:\n\n- For numbers of the form n = 4*x + 1, only the last last two bits differ from n and n+1, therefore only two extra steps in the \"partial_lucasVmod()\" function are needed to also compute V_n(P,Q) mod n, which is very cheap.\n- On the other hand, for numbers of the form n = 2^k - 1, all the bits of n and n+1 are different, which makes the computation of V_n(P,Q) quite expensive. But we can use the Lucas-Lehmer test for such numbers.\n- Numbers of the form x*2^k - 1, with x < 2^k, also take longer to check, but we can use the Lucas-Lehmer-Riesel (LLR) test for those.\n\nOptimization ideas:\n\n- To ensure that the test is always fast, we can skip the computation of V_n(P,Q) if the length of the remaining bits of n is too large (e.g. larger than the number of bits of d). This bounds the running time of the test to: 1.5 * (the cost of computing V_n(P,Q) mod n), while still having no known counter-examples.\n- In the selection of parameters (P,Q), we can start with Q = -2 and finding the first P >= 2 that satisfies jacobi(P^2 - 4*Q, n) = -1. The reason being that it is faster for computers to multiply by powers of two, and thus it makes the computation of the Lucas V sequence a bit faster, since |Q| is a power of two and, most of the time, P is also a power of 2.\n- In a general-purpose \"is_prime(n)\" function, for performance reasons, we should also do a little bit of trial-division (or gcd with primorials) and then a strong pseudoprime test to base 2, trying to return early if possible.\n"
  },
  {
    "path": "Math/is_omega_prime.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 February 2023\n# https://github.com/trizen\n\n# A simple and fast method for checking if a given integer n has exactly k distinct prime factors (i.e.: omega(n) = k).\n\nuse 5.020;\nuse warnings;\n\nuse ntheory      qw(:all);\nuse experimental qw(signatures);\n\nuse Math::GMPz;\nuse Math::Prime::Util::GMP;\n\nuse constant {\n              TRIAL_LIMIT        => 1e3,\n              HAS_NEW_PRIME_UTIL => defined(&Math::Prime::Util::is_omega_prime),\n             };\n\nmy @SMALL_PRIMES = @{primes(TRIAL_LIMIT)};\n\nsub mpz_is_omega_prime ($n, $k) {\n\n    state $z = Math::GMPz::Rmpz_init();\n    state $t = Math::GMPz::Rmpz_init();\n\n    if ($n == 0) {\n        return 0;\n    }\n\n    Math::GMPz::Rmpz_set_str($z, \"$n\", 10);\n    Math::GMPz::Rmpz_root($t, $z, $k);\n\n    my $trial_limit = Math::GMPz::Rmpz_get_ui($t);\n\n    if ($trial_limit > TRIAL_LIMIT or !Math::GMPz::Rmpz_fits_ulong_p($t)) {\n        $trial_limit = TRIAL_LIMIT;\n    }\n\n    foreach my $p (@SMALL_PRIMES) {\n\n        last if ($p > $trial_limit);\n\n        if (Math::GMPz::Rmpz_divisible_ui_p($z, $p)) {\n            --$k;\n            Math::GMPz::Rmpz_set_ui($t, $p);\n            Math::GMPz::Rmpz_remove($z, $z, $t);\n        }\n\n        ($k > 0) or last;\n\n        if (HAS_NEW_PRIME_UTIL and Math::GMPz::Rmpz_fits_ulong_p($z)) {\n            return Math::Prime::Util::is_omega_prime($k, Math::GMPz::Rmpz_get_ui($z));\n        }\n    }\n\n    if (Math::GMPz::Rmpz_cmp_ui($z, 1) == 0) {\n        return ($k == 0);\n    }\n\n    if ($k == 0) {\n        return (Math::GMPz::Rmpz_cmp_ui($z, 1) == 0);\n    }\n\n    if ($k == 1) {\n\n        if (Math::GMPz::Rmpz_fits_ulong_p($z)) {\n            return is_prime_power(Math::GMPz::Rmpz_get_ui($z));\n        }\n\n        return Math::Prime::Util::GMP::is_prime_power(Math::GMPz::Rmpz_get_str($z, 10));\n    }\n\n    Math::GMPz::Rmpz_ui_pow_ui($t, next_prime($trial_limit), $k);\n\n    if (Math::GMPz::Rmpz_cmp($z, $t) < 0) {\n        return 0;\n    }\n\n    (HAS_NEW_PRIME_UTIL and Math::GMPz::Rmpz_fits_ulong_p($z))\n      ? Math::Prime::Util::is_omega_prime($k, Math::GMPz::Rmpz_get_ui($z))\n      : (factor_exp(Math::GMPz::Rmpz_get_str($z, 10)) == $k);\n}\n\nforeach my $n (1 .. 100) {\n    my $t = urandomb($n) + 1;\n\n    say \"Testing: $t\";\n\n    foreach my $k (1 .. 20) {\n        if (HAS_NEW_PRIME_UTIL ? Math::Prime::Util::is_omega_prime($k, $t) : (factor_exp($t) == $k)) {\n            mpz_is_omega_prime($t, $k) || die \"error for: ($t, $k)\";\n        }\n        elsif (mpz_is_omega_prime($t, $k)) {\n            die \"counter-example: ($t, $k)\";\n        }\n    }\n}\n"
  },
  {
    "path": "Math/is_perfect_power.pl",
    "content": "#!/usr/bin/perl\n\n# Algorithm for testing if a given number `n` is a perfect\n# power (i.e. can be expressed as: n = a^k with k > 1).\n\n# The value of k is returned when n is an exact k-th power, 1 otherwise.\n\n# Algorithm presented in the book:\n#\n#   Modern Computer Arithmetic\n#           - by Richard P. Brent and Paul Zimmermann\n#\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(logint rootint powint);\nuse experimental qw(signatures);\n\nsub is_perfect_power ($n) {\n\n    for (my $k = logint($n, 2) ; $k >= 2 ; --$k) {\n        if (powint(rootint($n, $k), $k) == $n) {\n            return $k;\n        }\n    }\n\n    return 1;\n}\n\nsay is_perfect_power(powint(1234, 14));    #=> 14\n"
  },
  {
    "path": "Math/is_smooth_over_product.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 25 October 2018\n# https://github.com/trizen\n\n# A new algorithm for testing N for B-smoothness, given the product of a subset of primes <= B.\n# Returns a true value when N is the product of a subset of prime factors of B.\n# This algorithm can be useful in some modern integer factorization algorithms.\n\n# Algorithm:\n#     1. Let n be the number to be tested.\n#     2. Let k be the product of the primes in the factor base.\n#     3. Compute the greatest common divisor: g = gcd(n, k)\n#     4. If g is greater than 1, then n = r * g^e, for some e >= 1.\n#        - If r = 1, then n is smooth over the factor base.\n#        - Otherwise, set n = r and go to step 3.\n#     5. If this step is reached, then n is not smooth over the factor base.\n\nuse 5.020;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(gcd valuation primorial factor);\n\nsub is_smooth_over_prod ($n, $k) {\n\n    for (my $g = gcd($n, $k) ; $g > 1 ; $g = gcd($n, $k)) {\n        $n /= $g;                         # remove one divisor g\n        $n /= $g while ($n % $g == 0);    # remove any divisibility by g\n        return 1 if ($n == 1);            # smooth if n == 1\n    }\n\n    return 0;\n}\n\n# Example for identifying 19-smooth numbers\nmy $k = primorial(19);                    # product of primes <= 19\n\nfor my $n (1 .. 1000) {\n    say($n, \" = prod(\", join(', ', factor($n)), \")\") if is_smooth_over_prod($n, $k);\n}\n"
  },
  {
    "path": "Math/is_squarefree_over_product.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 16 March 2019\n# https://github.com/trizen\n\n# Efficient algorithm for determinining if a given number is squarefree over a squarefree product.\n\n# Algorithm:\n#     1. Let n be the number to be tested.\n#     2. Let k be the product of the primes <= B.\n#     3. Compute the greatest common divisor: g = gcd(n, k)\n#     4. If g is greater than 1, then n = r*g.\n#        - If r = 1, then n is B-smooth and squarefree.\n#        - Otherwise, if gcd(r, k) > 1, then n is not squarefree.\n#     5. If this step is reached, then n is not B-smooth.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\nuse ntheory qw(primorial factor);\nuse experimental qw(signatures);\n\nsub is_squarefree_over_prod ($n, $k) {\n\n    state $g = Math::GMPz::Rmpz_init_nobless();\n    state $t = Math::GMPz::Rmpz_init_nobless();\n\n    # Compute the greatest common divisor: g = gcd(n, k)\n    Math::GMPz::Rmpz_set($t, $n);\n    Math::GMPz::Rmpz_gcd($g, $t, $k);\n\n    if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {\n\n        # If g is greater than 1, then n = r*g.\n        Math::GMPz::Rmpz_divexact($t, $t, $g);\n\n        # If r = 1, then n is squarefree.\n        return 1 if Math::GMPz::Rmpz_cmp_ui($t, 1) == 0;\n\n        # Otherwise, if gcd(r, k) > 1, then n is not squarefree.\n        Math::GMPz::Rmpz_gcd($g, $t, $k);\n\n        if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {\n            return 0;\n        }\n    }\n\n    # If this step is reached, then n is not B-smooth.\n    return 0;\n}\n\nmy $k = Math::GMPz->new(primorial(19));    # product of primes <= 19\n\nforeach my $n (1 .. 100) {\n    if (is_squarefree_over_prod(Math::GMPz->new($n), $k)) {\n        say \"$n is 19-squarefree: prod(\", join(', ', factor($n)), \")\";\n    }\n}\n"
  },
  {
    "path": "Math/is_sum_of_two_cubes.pl",
    "content": "#!/usr/bin/perl\n\n# Determine if a given integer can be represented as a sum of two nonnegative cubes.\n\n# See also:\n#   https://oeis.org/A004999 -- Sums of two nonnegative cubes.\n#   https://cs.uwaterloo.ca/journals/JIS/VOL6/Broughan/broughan25.pdf\n\nuse 5.020;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub is_sum_of_two_cubes($n) {\n\n    my $L = rootint($n-1, 3) + 1;\n    my $U = rootint(4*$n, 3);\n\n    foreach my $m (divisors($n)) {\n        if ($L <= $m and $m <= $U) {\n            my $l = $m*$m - $n/$m;\n            $l % 3 == 0 or next;\n            $l /= 3;\n            is_square($m*$m - 4*$l) && return 1;\n        }\n    }\n\n    return;\n}\n\nforeach my $n (1 .. 1000) {\n    if (is_sum_of_two_cubes($n)) {\n        print($n, \", \");\n    }\n}\n"
  },
  {
    "path": "Math/is_sum_of_two_squares.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 10 May 2016\n# https://github.com/trizen\n\n# Determine if a given number can be written as the sum of two squares.\n\n# See also:\n#   https://wstein.org/edu/Fall2001/124/lectures/lecture21/lecture21/node2.html\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(factor_exp is_prime);\n\nsub is_sum_of_2_squares {\n    my ($n) = @_;\n\n    if (is_prime($n)) {\n        return 1 if $n == 2;\n        return $n % 4 == 1;\n    }\n\n    foreach my $p (factor_exp($n)) {\n            $p->[0] % 4 == 3\n        and $p->[1] % 2 != 0\n        and return 0;\n    }\n\n    return 1;\n}\n\nfor my $i (0 .. 50) {\n    if (is_sum_of_2_squares($i)) {\n        say $i;\n    }\n}\n"
  },
  {
    "path": "Math/iterative_difference_of_central_divisors_to_reach_zero.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 22 March 2019\n# https://github.com/trizen\n\n# Let f(n) be the difference between the least divisor of n that is >= sqrt(n) and the greatest divisor of n that is <= sqrt(n).\n# Let g(n) be the number of iterations of f(n) required to reach zero.\n\n# Then a(n) is the smallest integer k of the form x*(x + a(n-1)), such that g(k) = n, for some positive integer x, with a(0) = 0.\n\n# This sequence provides upper-bounds for:\n#   https://oeis.org/A324921\n\n# Example:\n#   a(30) = 940055257114567466733218694 = 42 * (42 + 205 * (205 + 68 * (68 + 9 * (9 + 56 * (56 + 53 * (53 + 14 * (14 + 5 * (5 + 34 * (34 + 73 * (73 + 6 * (6 + 43 * (43 + 8 * (8 + 3 * (3 + 10 * (10 + 9 * (9 + 4 * (4 + 7 * (7 + 12 * (12 + 5 * (5 + 2 * (2 + 1 * (1 + 2 * (2 + 3 * (3 + 2 * (2 + 1 * (1 + 2 * (2 + 1 * (1 + 1 * (1 + 1 * (1 + 0))))))))))))))))))))))))))))))\n\n# OEIS sequences:\n#   https://oeis.org/A324921 -- Index of first occurrence of n in A324920.\n#   https://oeis.org/A056737 -- Minimum nonnegative integer m such that n = k*(k+m) for some positive integer k.\n#   https://oeis.org/A324920 -- a(n) is the number of iterations of the integer splitting function (A056737) necessary to reach zero.\n\nuse 5.020;\nuse warnings;\n\nuse Math::GMPz;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub f($n) {\n    if (is_square($n)) {\n        0;\n    }\n    else {\n        my @d = divisors($n);\n        Math::GMPz->new($d[(1 + $#d) >> 1]) - $d[($#d) >> 1];\n    }\n}\n\nsub g($n) {\n\n    my $t     = f($n);\n    my $count = 1;\n\n    while ($t) {\n        $t = f($t);\n        ++$count;\n    }\n\n    $count;\n}\n\nmy $n = Math::GMPz->new(0);\n\nfor my $j (1 .. 30) {\n\n    for (my $x = 1 ; ; ++$x) {\n\n        my $k = $x * ($n + $x);\n        my $t = g($k);\n\n        if ($t == $j) {\n            $n = $k;\n            say \"a($j) = $k\";\n            last;\n        }\n    }\n}\n\n__END__\na(1)  = 1\na(2)  = 2\na(3)  = 3\na(4)  = 10\na(5)  = 11\na(6)  = 26\na(7)  = 87\na(8)  = 178\na(9)  = 179\na(10) = 362\na(11) = 1835\na(12) = 22164\na(13) = 155197\na(14) = 620804\na(15) = 5587317\na(16) = 55873270\na(17) = 167619819\na(18) = 1340958616\na(19) = 57661222337\na(20) = 345967334058\na(21) = 25255615391563\na(22) = 858690923314298\na(23) = 4293454616571515\na(24) = 60108364632001406\na(25) = 3185743325496077327\na(26) = 178401626227780333448\na(27) = 1605614636050023001113\na(28) = 109181795251401564080308\na(29) = 22382268026537320636505165\na(30) = 940055257114567466733218694\na(31) = 102466023025487853873920849527\na(32) = 3688776828917562739461150584268\na(33) = 217637832906136201628207884475293\na(34) = 10011340313682265274897562685865594\na(35) = 830941246035628017816497702926851191\na(36) = 74784712143206521603484793263416615290\na(37) = 9946366715046467373263477504034409851259\na(38) = 1233349472665761954284671210500266821571492\na(39) = 11100145253991857588562040894502401394143509\na(40) = 155402033555886006239868572523033619518009322\na(41) = 6060679308679554243354874328398311161202365079\na(42) = 12121358617359108486709748656796622322404730162\na(43) = 1321228089292142825051362603590831833142115599539\na(44) = 295955092001439992811505223204346330623833894346912\na(45) = 3255506012015839920926557455247809636862172837816153\na(46) = 97665180360475197627796723657434289105865185134485490\na(47) = 8887531412803242984129501852826520308633731847238187871\na(48) = 106650376953638915809554022233918243703604782166858254596\na(49) = 23143131798939644730673222824760258883682237730208241294421\na(50) = 2036595598306688736299243608578902781764036920258325233916792\n"
  },
  {
    "path": "Math/k-imperfect_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Generate all the k-imperfect numbers less than or equal to n.\n# Based on Michel Marcus's algorithm from A328860.\n\n# k-imperfect numbers, are numbers n such that:\n#   n = k * Sum_{d|n} d * (-1)^Ω(n/d)\n\n# See also:\n#   https://oeis.org/A206369 -- rho function.\n#   https://oeis.org/A127724 -- k-imperfect numbers for some k >= 1.\n#   https://oeis.org/A127725 -- Numbers that are 2-imperfect.\n#   https://oeis.org/A127726 -- Numbers that are 3-imperfect.\n#   https://oeis.org/A328860 -- Numbers that are 4-imperfect.\n\nuse 5.020;\nuse warnings;\n\nuse ntheory qw(:all);\nuse List::Util qw(uniq);\nuse experimental qw(signatures);\n\nsub rho_prime_power ($p, $e) {\n    my $x = addint(powint($p, $e + 1), $p >> 1);\n    my $y = $p + 1;\n    divint($x, $y);\n}\n\nsub rho_factors(@F) {\n    vecprod(map { rho_prime_power($_->[0], $_->[1]) } @F);\n}\n\nsub k_imperfect_numbers ($limit, $A, $B = 1) {\n\n    my @sol;\n    my $g = gcd($A, $B);\n\n    $A = divint($A, $g);\n    $B = divint($B, $g);\n\n    if ($A == 1) {\n        return (1) if ($B == 1);\n        return ();\n    }\n\n    my @f   = factor_exp($A);\n    my $rho = rho_factors(@f);\n    my ($p, $n) = @{$f[-1]};\n\n    my $r = rho_prime_power($p, $n);\n\n    for (my $pn = powint($p, $n) ; $pn <= $limit ; $pn = mulint($pn, $p)) {\n        foreach my $k (__SUB__->(divint($limit, $pn), mulint($A, $r), mulint($B, $pn))) {\n            push @sol, mulint($pn, $k) if (gcd($pn, $k) == 1);\n        }\n        $r = rho_prime_power($p, ++$n);\n    }\n\n    if ($rho == $B) {\n        push @sol, $A;\n    }\n\n    @sol = grep { $_ <= $limit } @sol;\n    @sol = sort { $a <=> $b } @sol;\n    uniq(@sol);\n}\n\nsay join ', ', k_imperfect_numbers(10**15, 2);    # 2-imperfect numbers\nsay join ', ', k_imperfect_numbers(10**15, 3);    # 3-imperfect numbers\n\n__END__\n2, 12, 40, 252, 880, 10880, 75852, 715816960, 62549517598720\n6, 120, 126, 2520, 2640, 30240, 32640, 37800, 37926, 55440, 685440, 758520, 831600, 2600640, 5533920, 6917400, 9102240, 10281600, 11377800, 16687440, 152182800, 206317440, 250311600, 475917120, 866829600, 1665709920, 1881532800, 2082137400, 2147450880, 3094761600, 7660224000, 45096468480, 45807022800, 74547345600, 76324550400, 566341372800, 676447027200, 1265637895200, 1401820992000, 1422467373600, 1769199213600, 10463865984000, 13574037012480, 15634517184000, 19954883520000, 22973689670400, 108844858987200, 122332194129600, 123789805977600, 130728955864320, 152151132369600, 187648552796160, 203610555187200\n"
  },
  {
    "path": "Math/k-odd-powerful_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 11 February 2020\n# Edit: 23 February 2024\n# https://github.com/trizen\n\n# Fast recursive algorithm for generating all the odd k-powerful numbers <= n.\n# A positive integer n is considered k-powerful, if for every prime p that divides n, so does p^k.\n\n# Example:\n#   2-powerful = a^2 * b^3,             for a,b >= 1\n#   3-powerful = a^3 * b^4 * c^5,       for a,b,c >= 1\n#   4-powerful = a^4 * b^5 * c^6 * d^7, for a,b,c,d >= 1\n\n# See also:\n#   https://oeis.org/A062739\n\nuse 5.036;\nuse ntheory qw(:all);\n\nsub odd_powerful_numbers ($n, $k = 2) {\n\n    my @odd_powerful;\n\n    sub ($m, $r) {\n\n        if ($r < $k) {\n            push @odd_powerful, $m;\n            return;\n        }\n\n        foreach my $v (1 .. rootint(divint($n, $m), $r)) {\n\n            next if ($v % 2 == 0);\n\n            if ($r > $k) {\n                gcd($m, $v) == 1   or next;\n                is_square_free($v) or next;\n            }\n\n            __SUB__->(mulint($m, powint($v, $r)), $r - 1);\n        }\n      }\n      ->(1, 2 * $k - 1);\n\n    sort { $a <=> $b } @odd_powerful;\n}\n\nforeach my $k (1 .. 10) {\n    printf(\"%2d-odd-powerful: %s, ...\\n\", $k, join(\", \", odd_powerful_numbers(powint(10, $k), $k)));\n}\n\n__END__\n 1-odd-powerful: 1, 3, 5, 7, 9, ...\n 2-odd-powerful: 1, 9, 25, 27, 49, 81, ...\n 3-odd-powerful: 1, 27, 81, 125, 243, 343, 625, 729, ...\n 4-odd-powerful: 1, 81, 243, 625, 729, 2187, 2401, 3125, 6561, ...\n 5-odd-powerful: 1, 243, 729, 2187, 3125, 6561, 15625, 16807, 19683, 59049, 78125, ...\n 6-odd-powerful: 1, 729, 2187, 6561, 15625, 19683, 59049, 78125, 117649, 177147, 390625, 531441, 823543, ...\n 7-odd-powerful: 1, 2187, 6561, 19683, 59049, 78125, 177147, 390625, 531441, 823543, 1594323, 1953125, 4782969, 5764801, 9765625, ...\n 8-odd-powerful: 1, 6561, 19683, 59049, 177147, 390625, 531441, 1594323, 1953125, 4782969, 5764801, 9765625, 14348907, 40353607, 43046721, 48828125, ...\n 9-odd-powerful: 1, 19683, 59049, 177147, 531441, 1594323, 1953125, 4782969, 9765625, 14348907, 40353607, 43046721, 48828125, 129140163, 244140625, 282475249, 387420489, ...\n10-odd-powerful: 1, 59049, 177147, 531441, 1594323, 4782969, 9765625, 14348907, 43046721, 48828125, 129140163, 244140625, 282475249, 387420489, 1162261467, 1220703125, 1977326743, 3486784401, 6103515625, ...\n"
  },
  {
    "path": "Math/k-powerful_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 11 February 2020\n# https://github.com/trizen\n\n# Fast recursive algorithm for generating all the k-powerful numbers <= n.\n# A positive integer n is considered k-powerful, if for every prime p that divides n, so does p^k.\n\n# Example:\n#   2-powerful = a^2 * b^3,             for a,b >= 1\n#   3-powerful = a^3 * b^4 * c^5,       for a,b,c >= 1\n#   4-powerful = a^4 * b^5 * c^6 * d^7, for a,b,c,d >= 1\n\n# OEIS:\n#   https://oeis.org/A001694 -- 2-powerful numbers\n#   https://oeis.org/A036966 -- 3-powerful numbers\n#   https://oeis.org/A036967 -- 4-powerful numbers\n#   https://oeis.org/A069492 -- 5-powerful numbers\n#   https://oeis.org/A069493 -- 6-powerful numbers\n\nuse 5.020;\nuse warnings;\n\nuse ntheory      qw(:all);\nuse experimental qw(signatures);\n\nsub powerful_numbers ($n, $k = 2) {\n\n    my @powerful;\n\n    sub ($m, $r) {\n\n        if ($r < $k) {\n            push @powerful, $m;\n            return;\n        }\n\n        foreach my $v (1 .. rootint(divint($n, $m), $r)) {\n\n            if ($r > $k) {\n                gcd($m, $v) == 1   or next;\n                is_square_free($v) or next;\n            }\n\n            __SUB__->(mulint($m, powint($v, $r)), $r - 1);\n        }\n\n      }\n      ->(1, 2 * $k - 1);\n\n    sort { $a <=> $b } @powerful;\n}\n\nforeach my $k (1 .. 10) {\n    printf(\"%2d-powerful: %s, ...\\n\", $k, join(\", \", powerful_numbers(5**$k, $k)));\n}\n\n__END__\n 1-powerful: 1, 2, 3, 4, 5, ...\n 2-powerful: 1, 4, 8, 9, 16, 25, ...\n 3-powerful: 1, 8, 16, 27, 32, 64, 81, 125, ...\n 4-powerful: 1, 16, 32, 64, 81, 128, 243, 256, 512, 625, ...\n 5-powerful: 1, 32, 64, 128, 243, 256, 512, 729, 1024, 2048, 2187, 3125, ...\n 6-powerful: 1, 64, 128, 256, 512, 729, 1024, 2048, 2187, 4096, 6561, 8192, 15625, ...\n 7-powerful: 1, 128, 256, 512, 1024, 2048, 2187, 4096, 6561, 8192, 16384, 19683, 32768, 59049, 65536, 78125, ...\n 8-powerful: 1, 256, 512, 1024, 2048, 4096, 6561, 8192, 16384, 19683, 32768, 59049, 65536, 131072, 177147, 262144, 390625, ...\n 9-powerful: 1, 512, 1024, 2048, 4096, 8192, 16384, 19683, 32768, 59049, 65536, 131072, 177147, 262144, 524288, 531441, 1048576, 1594323, 1953125, ...\n10-powerful: 1, 1024, 2048, 4096, 8192, 16384, 32768, 59049, 65536, 131072, 177147, 262144, 524288, 531441, 1048576, 1594323, 2097152, 4194304, 4782969, 8388608, 9765625, ...\n"
  },
  {
    "path": "Math/k-powerful_numbers_in_range.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 28 February 2021\n# Edit: 11 April 2024\n# https://github.com/trizen\n\n# Fast recursive algorithm for generating all the k-powerful numbers in a given range [A,B].\n# A positive integer n is considered k-powerful, if for every prime p that divides n, so does p^k.\n\n# Example:\n#   2-powerful = a^2 * b^3,             for a,b >= 1\n#   3-powerful = a^3 * b^4 * c^5,       for a,b,c >= 1\n#   4-powerful = a^4 * b^5 * c^6 * d^7, for a,b,c,d >= 1\n\n# OEIS:\n#   https://oeis.org/A001694 -- 2-powerful numbers\n#   https://oeis.org/A036966 -- 3-powerful numbers\n#   https://oeis.org/A036967 -- 4-powerful numbers\n#   https://oeis.org/A069492 -- 5-powerful numbers\n#   https://oeis.org/A069493 -- 6-powerful numbers\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\n\nsub my_powerful_numbers ($A, $B, $k = 2) {\n\n    my @powerful;\n\n    sub ($m, $r) {\n\n        my $from = 1;\n        my $upto = rootint(divint($B, $m), $r);\n\n        if ($r <= $k) {\n\n            if ($A > $m) {\n\n                # Optimization by Dana Jacobsen (from Math::Prime::Util::PP)\n                my $l = cdivint($A, $m);\n                if (($l >> $r) == 0) {\n                    $from = 2;\n                }\n                else {\n                    $from = rootint($l, $r);\n                    $from++ if (powint($from, $r) != $l);\n                }\n            }\n\n            foreach my $j ($from .. $upto) {\n                push @powerful, mulint($m, powint($j, $r));\n            }\n\n            return;\n        }\n\n        foreach my $v ($from .. $upto) {\n\n            gcd($m, $v) == 1   or next;\n            is_square_free($v) or next;\n\n            __SUB__->(mulint($m, powint($v, $r)), $r - 1);\n        }\n      }\n      ->(1, 2 * $k - 1);\n\n    sort { $a <=> $b } @powerful;\n}\n\nmy $A = int rand 1e5;\nmy $B = int rand 1e7;\n\nforeach my $k (2 .. 5) {\n    say \"Testing: k = $k\";\n    my @a1 = my_powerful_numbers($A, $B, $k);\n    my @a2 = @{powerful_numbers($A, $B, $k)};\n    my @a3 = grep { $_ >= $A } my_powerful_numbers(1, $B, $k);\n    \"@a1\" eq \"@a2\" or die \"error for: powerful_numbers($A, $B, $k)\";\n    \"@a1\" eq \"@a3\" or die \"error for: powerful_numbers($A, $B, $k)\";\n}\n\nsay join(', ', my_powerful_numbers(1e6 - 1e4, 1e6, 2));    #=> 990025, 990125, 990584, 991232, 992016, 994009, 995328, 996004, 996872, 998001, 998784, 1000000\n"
  },
  {
    "path": "Math/karatsuba_multiplication.pl",
    "content": "#!/usr/bin/perl\n\n# A simple implementation of the Karatsuba multiplication.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Karatsuba_algorithm\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Math::AnyNum qw(:overload);\nuse Math::AnyNum qw(divmod);\n\nsub karatsuba_multiplication ($x, $y, $n = 8) {\n\n    if ($n <= 1) {\n        return $x * $y;\n    }\n\n    my $m = ($n % 2 == 0) ? ($n >> 1) : (($n >> 1) + 1);\n\n    my ($a, $b) = divmod($x, 1 << $m);\n    my ($c, $d) = divmod($y, 1 << $m);\n\n    my $e = __SUB__->($a,      $c,      $m);\n    my $f = __SUB__->($b,      $d,      $m);\n    my $g = __SUB__->($a - $b, $c - $d, $m);\n\n    ($e << (2*$m)) + (($e + $f - $g) << $m) + $f;\n}\n\nsay karatsuba_multiplication(122, 422);    # 122 * 422 = 51484\n"
  },
  {
    "path": "Math/kempner_binomial_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 08 January 2019\n# https://github.com/trizen\n\n# a(n) = smallest positive integer k such that n divides binomial(n+k, k).\n\n# Sequence inspired by the Kempner numbers:\n#   https://oeis.org/A002034\n\n# Prime power identity:\n#   a(p^k) = p^k * (p^k - 1), for p^k a prime power.\n\n# Lower bound formula for a(n). Let:\n#   f(n, p^k) = p^k * (p^k - n/p^k)\n\n# if n = p1^e1 * p2^e2 * ... * pu^eu,\n# then a(n) >= max( f(n,p1^e1), f(n,p2^e2), ..., f(n,pu^eu) ).\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse ntheory qw(factor_exp);\nuse Math::AnyNum qw(binomial is_div ipow max);\n\nsub f ($n) {\n    for (my $k = 1 ; ; ++$k) {\n        if (is_div(binomial($n + $k, $k), $n)) {\n            return $k;\n        }\n    }\n}\n\nsub g($n) {    # g(n) <= f(n)\n    max(map {\n        my $pk = ipow($_->[0], $_->[1]);\n        $pk * ($pk - $n / $pk)\n    } factor_exp($n));\n}\n\nsay \"f(n) = [\", join(\", \", map { f($_) } 2 .. 31), \"]\";\nsay \"g(n) = [\", join(\", \", map { g($_) } 2 .. 31), \"]\";\n\n__END__\nf(n) = [2, 6, 12, 20, 3, 42, 56, 72, 15, 110, 6, 156, 35, 12, 240, 272, 63, 342, 12, 33, 99, 506, 40, 600, 143, 702, 21, 812, 24, 930]\ng(n) = [2, 6, 12, 20, 3, 42, 56, 72, 15, 110, 4, 156, 35, 10, 240, 272, 63, 342,  5, 28, 99, 506, 40, 600, 143, 702, 21, 812, -5, 930]\n"
  },
  {
    "path": "Math/klein_J_invariant_and_modular_lambda.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 03 October 2017\n# https://github.com/trizen\n\n# Implementation of the `modular_lambda(x)` and `klein_invariant_j(x)` functions.\n\n# See also:\n#   https://oeis.org/A115977\n#   https://en.wikipedia.org/wiki/J-invariant\n#   https://en.wikipedia.org/wiki/Modular_lambda_function\n\nuse 5.014;\nuse warnings;\n\nuse Math::AnyNum qw(:overload pi);\n\nmy @A115977 = map { Math::AnyNum->new((split(' '))[-1]) } <DATA>;\n\nsub modular_lambda {\n    my ($x) = @_;\n\n    my $sum  = 0;\n    my $prev = 0;\n\n    my $q = exp(pi * i * $x);\n\n    $q = $q->real if $q->is_real;\n\n    foreach my $i (0 .. $#A115977) {\n        $sum += $A115977[$i] * $q**($i + 1);\n        $sum->approx_cmp($prev) || last;\n        $prev = $sum;\n    }\n\n    return $sum;\n}\n\nsub klein_invariant_j {\n    my ($x) = @_;\n\n#<<<\n    ( 4 * (1 - modular_lambda($x)     + modular_lambda($x)**2)**3) /\n    (27 * (1 - modular_lambda($x))**2 * modular_lambda($x)**2);\n#>>>\n\n}\n\nsay klein_invariant_j(2 * i);                               # (11/2)^3\nsay klein_invariant_j(sqrt(-2))->round(-40);                # (5/3)^3\nsay klein_invariant_j((1 + sqrt(-163)) / 2)->round(-40);    # -53360^3\n\n__END__\n1 16\n2 -128\n3 704\n4 -3072\n5 11488\n6 -38400\n7 117632\n8 -335872\n9 904784\n10 -2320128\n11 5702208\n12 -13504512\n13 30952544\n14 -68901888\n15 149403264\n16 -316342272\n17 655445792\n18 -1331327616\n19 2655115712\n20 -5206288384\n21 10049485312\n22 -19115905536\n23 35867019904\n24 -66437873664\n25 121587699568\n26 -219997823744\n27 393799671680\n28 -697765502976\n29 1224470430560\n30 -2129120769024\n31 3669925002752\n32 -6273295187968\n33 10638472274688\n34 -17904375855360\n35 29914108051712\n36 -49631878364160\n37 81796581923552\n38 -133940954877440\n39 217972711694464\n40 -352615521042432\n41 567159563764128\n42 -907197891465216\n43 1443361173729344\n44 -2284561115754496\n45 3597986508088416\n46 -5639173569598464\n47 8797049785486592\n48 -13661151873466368\n49 21121565013141648\n50 -32516981110373248\n51 49853282901399936\n52 -76125157989107712\n53 115787750395675104\n54 -175446129968544768\n55 264860028797210496\n56 -398403552976764928\n57 597179610339831040\n58 -892073853566196480\n59 1328153150761957184\n60 -1970983069740490752\n61 2915677205543637344\n"
  },
  {
    "path": "Math/lambert_W_function.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 27 December 2016\n# https://github.com/trizen\n\n# A simple implementation of Lambert's W function.\n\n# Example: x^x = 100\n#            x = exp(lambert_w(log(100)))\n#            x =~ 3.5972850235404...\n\n# See also:\n#   https://en.wikipedia.org/wiki/Lambert_W_function\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload approx_cmp);\n\nsub lambert_w {\n    my ($c) = @_;\n\n    my $x = sqrt($c) + 1;\n    my $y = 0;\n\n    while (approx_cmp(abs($x - $y), 0)) {\n        $y = $x;\n        $x = ($x + $c) / (1 + log($x));\n    }\n\n    log($x);\n}\n\nsay exp(lambert_w(log(100)));    # 3.59728502354041750549765225178228606913554305489\nsay exp(lambert_w(log(-100)));   # 3.70202936660214594290193962952737102802777010583+1.34823128471151901327831464969872480416292147614i\n"
  },
  {
    "path": "Math/lambert_W_function_complex.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 26 December 2016\n# https://github.com/trizen\n\n# Implementation of the Lambert-W function in complex numbers.\n\n# Example: x^x = 100\n#            x = exp(lambert_w(log(100)))\n#            x =~ 3.59728502354042\n\n# See also:\n#   https://en.wikipedia.org/wiki/Lambert_W_function\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::MPC;\nuse Math::MPFR;\n\nmy $PREC  = 128;                      # can be tweaked\nmy $ROUND = Math::MPC::MPC_RNDNN();\n\nsub lambert_w {\n    my ($c) = @_;\n\n    if (ref($c) ne 'Math::MPC') {\n        my $n = Math::MPC::Rmpc_init2($PREC);\n        Math::MPC::Rmpc_set_str($n, \"$c\", 10, $ROUND);\n        $c = $n;\n    }\n\n    my $p = Math::MPFR::Rmpfr_init2($PREC);\n    Math::MPFR::Rmpfr_ui_pow_ui($p, 10, int($PREC / 4), $ROUND);\n    Math::MPFR::Rmpfr_ui_div($p, 1, $p, $ROUND);\n\n    my $x = Math::MPC::Rmpc_init2($PREC);\n    Math::MPC::Rmpc_set($x, $c, $ROUND);\n    Math::MPC::Rmpc_sqrt($x, $x, $ROUND);\n    Math::MPC::Rmpc_add_ui($x, $x, 1, $ROUND);\n\n    my $y = Math::MPC::Rmpc_init2($PREC);\n    Math::MPC::Rmpc_set_ui($y, 0, $ROUND);\n\n    my $tmp = Math::MPC::Rmpc_init2($PREC);\n    my $abs = Math::MPFR::Rmpfr_init2($PREC);\n\n    my $count = 0;\n    while (1) {\n        Math::MPC::Rmpc_sub($tmp, $x, $y, $ROUND);\n\n        Math::MPC::Rmpc_abs($abs, $tmp, $ROUND);\n        Math::MPFR::Rmpfr_cmp($abs, $p) <= 0 and last;\n\n        Math::MPC::Rmpc_set($y, $x, $ROUND);\n\n        Math::MPC::Rmpc_log($tmp, $x, $ROUND);\n        Math::MPC::Rmpc_add_ui($tmp, $tmp, 1, $ROUND);\n\n        Math::MPC::Rmpc_add($x, $x, $c, $ROUND);\n        Math::MPC::Rmpc_div($x, $x, $tmp, $ROUND);\n        last if ++$count > $PREC;\n    }\n\n    Math::MPC::Rmpc_log($x, $x, $ROUND);\n    $x;\n}\n\nsay lambert_w(100);     #  3.385630140290050184888244364529726867493\nsay lambert_w(-100);    #  3.205380786307449372155918213968303847481  + 2.482590531815923582117041287234452276982i\nsay lambert_w(-0.5);    # -0.7940236323446893679630153219005898091005 + 0.770111750510379109681313077405028929402i\n"
  },
  {
    "path": "Math/lanczos_approximation.pl",
    "content": "#!/usr/bin/perl\n\n# Algorithm from Wikipedia:\n#   https://en.wikipedia.org/wiki/Lanczos_approximation#Simple_implementation\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload pi real imag);\nuse experimental qw(signatures lexical_subs);\n\nsub gamma($z) {\n    my $epsilon = 0.0000001;\n\n    my sub withinepsilon($x) {\n        abs($x - abs($x)) <= $epsilon;\n    }\n\n    state $p = [\n        676.5203681218851,     -1259.1392167224028,\n        771.32342877765313,    -176.61502916214059,\n        12.507343278686905,    -0.13857109526572012,\n        9.9843695780195716e-6,  1.5056327351493116e-7,\n    ];\n\n    my $result;\n    if (real($z) < 0.5) {\n        $result = (pi / (sin(pi * $z) * gamma(1 - $z)));\n    }\n    else {\n        $z -= 1;\n        my $x = 0.99999999999980993;\n\n        while (my ($i, $pval) = each @$p) {\n            $x += $pval / ($z + $i + 1);\n        }\n\n        my $t = ($z + @$p - 0.5);\n        $result = (sqrt(pi * 2) * $t**($z + 0.5) * exp(-$t) * $x);\n    }\n\n    withinepsilon(imag($result)) ? real($result) : $result;\n}\n\nforeach my $i (0.5, 4, 5, 6, 30, 40, 50) {\n    printf(\"gamma(%3s) =~ %s\\n\", $i, gamma($i));\n}\n\n__END__\ngamma(0.5) =~ 1.77245385090551659496855986697771284175944211142\ngamma(  4) =~ 6.00000000000000628999184513591742545418327380194\ngamma(  5) =~ 24.0000000000000308599507225303222574058679398028\ngamma(  6) =~ 120.000000000000178632999163000072600390777175518\ngamma( 30) =~ 8841761993739669928012342097034.15093049782426111\ngamma( 40) =~ 20397882081197200259694400837033107505429486392\ngamma( 50) =~ 6.08281864034254395430563164837656389765153447987e62\n"
  },
  {
    "path": "Math/least_k_such_that_k_times_k-th_prime_is_greater_than_10_to_the_n.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 26 February 2019\n# https://github.com/trizen\n\n# Given a positive integer n, find the smallest integer `k` such that `k*prime(k) > 10^n`.\n\n# See also:\n#   https://oeis.org/A090977 -- Least k such that k*prime(k) > 10^n.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload bsearch_ge);\nuse ntheory qw(nth_prime nth_prime_lower nth_prime_upper);\n\nsub a {\n    my ($n) = @_;\n\n    my $lim = 10**$n;\n\n    my $min_approx = int(sqrt($lim / log($lim+1)));\n    my $max_approx = 2*$min_approx;\n\n    my $min = bsearch_ge($min_approx, $max_approx, sub {\n        nth_prime_upper($_) * $_ <=> $lim\n    });\n\n    my $max = bsearch_ge($min, $max_approx, sub {\n        nth_prime_lower($_) * $_ <=> $lim\n    });\n\n    bsearch_ge($min, $max, sub {\n        nth_prime($_) * $_ <=> $lim\n    });\n}\n\nforeach my $n(0..22) {\n    say \"a($n) = \", a($n);\n}\n\n__END__\na(0) = 1\na(1) = 3\na(2) = 7\na(3) = 17\na(4) = 48\na(5) = 134\na(6) = 382\na(7) = 1115\na(8) = 3287\na(9) = 9786\na(10) = 29296\na(11) = 88181\na(12) = 266694\na(13) = 809599\na(14) = 2465574\na(15) = 7528976\na(16) = 23045352\na(17) = 70684657\na(18) = 217196605\na(19) = 668461874\na(20) = 2060257099\na(21) = 6358076827\na(22) = 19644205359\n"
  },
  {
    "path": "Math/least_nonresidue.pl",
    "content": "#!/usr/bin/perl\n\n# Find the least nonresidue of n.\n\n# See also:\n#   https://oeis.org/A020649 -- Least nonresidue of n.\n#   https://oeis.org/A307809 -- Smallest \"non-residue\" pseudoprime to base prime(n).\n#   https://mathworld.wolfram.com/QuadraticNonresidue.html\n\nuse 5.020;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub least_nonresidue_odd ($n) {    # for odd n\n\n    my @factors = map { $_->[0] } factor_exp($n);\n\n    for (my $p = 2 ; ; $p = next_prime($p)) {\n        (vecall { kronecker($p, $_) == 1 } @factors) || return $p;\n    }\n}\n\nsub least_nonresidue_sqrtmod ($n) {    # for any n\n    for (my $p = 2 ; ; $p = next_prime($p)) {\n        sqrtmod($p, $n) // return $p;\n    }\n}\n\nmy @tests = (\n             3277,          3281,           121463,          491209,\n             11530801,      512330281,      15656266201,     139309114031,\n             7947339136801, 72054898434289, 334152420730129, 17676352761153241,\n             172138573277896681\n            );\n\nsay join ', ', map { least_nonresidue_odd($_) } @tests;        #=> 2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41\nsay join ', ', map { least_nonresidue_sqrtmod($_) } @tests;    #=> 2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41\n"
  },
  {
    "path": "Math/legendary_question_six.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 29 June 2019\n# https://github.com/trizen\n\n# The problem:\n#   Let \"a\" and \"b\" be positive integers such that a*b + 1 divides a^2 + b^2.\n#   Show that (a^2 + b^2) / (a*b + 1) is the square of an integer.\n\n# This program presents an efficient method for computing non-trivial solutions to the legendary question six.\n\n# The Legend of Question Six - Numberphile\n# https://www.youtube.com/watch?v=Y30VF3cSIYQ\n\n# The Return of the Legend of Question Six - Numberphile\n# https://www.youtube.com/watch?v=L0Vj_7Y2-xY\n\n# Solutions for (a^2 + b^2) / (1 + ab) = 4, are given by consecutive values of A052530 = { 2, 8, 30, 112, 418, 1560, 5822, ... }.\n\n# Example:\n#   (  2^2 +   8^2) / (    2*8 + 1) = 4\n#   (  8^2 +  30^2) / (   8*30 + 1) = 4\n#   ( 30^2 + 112^2) / ( 30*112 + 1) = 4\n#   (112^2 + 418^2) / (112*418 + 1) = 4\n\n# Similar sequences provide solutions for other values:\n\n# For 3^2: A065100 = { 3, 27, 240, 2133, 18957, 168480, ... }\n# For 4^2: A154021 = { 4, 64, 1020, 16256, 259076, 4128960, ... }\n# For 5^2: A154022 = { 5, 125, 3120, 77875, 1943755, 48516000, ... }\n# For 6^2: A154023 = { 6, 216, 7770, 279504, 10054374, 361677960, ... }\n\n# More generally, let U(n,x) be the Chebyshev polynomials of the second kind, then (a^2 + b^2) / (1 + ab) = m^2, has solutions of the form:\n#\n#   a = m * U(n, m^2 / 2)\n#   b = m * U(n+1, m^2 / 2)\n#\n# for any given positive integer m.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload chebyshevU);\n\nsub lq6_solutions ($m, $how_many = 5) {\n    map {\n        [$m * chebyshevU($_, $m*$m / 2), $m * chebyshevU($_ + 1, $m*$m / 2)]\n    } 0 .. $how_many-1;\n}\n\nforeach my $k (2 .. 10) {\n    my @S = lq6_solutions($k);\n    say \"(a^2 + b^2) / (1 + ab) = $k^2 has solutions: \", join(', ', map { \"[@$_]\" } @S);\n}\n\n__END__\n(a^2 + b^2) / (1 + ab) = 2^2 has solutions: [2 8], [8 30], [30 112], [112 418], [418 1560]\n(a^2 + b^2) / (1 + ab) = 3^2 has solutions: [3 27], [27 240], [240 2133], [2133 18957], [18957 168480]\n(a^2 + b^2) / (1 + ab) = 4^2 has solutions: [4 64], [64 1020], [1020 16256], [16256 259076], [259076 4128960]\n(a^2 + b^2) / (1 + ab) = 5^2 has solutions: [5 125], [125 3120], [3120 77875], [77875 1943755], [1943755 48516000]\n(a^2 + b^2) / (1 + ab) = 6^2 has solutions: [6 216], [216 7770], [7770 279504], [279504 10054374], [10054374 361677960]\n(a^2 + b^2) / (1 + ab) = 7^2 has solutions: [7 343], [343 16800], [16800 822857], [822857 40303193], [40303193 1974033600]\n(a^2 + b^2) / (1 + ab) = 8^2 has solutions: [8 512], [512 32760], [32760 2096128], [2096128 134119432], [134119432 8581547520]\n(a^2 + b^2) / (1 + ab) = 9^2 has solutions: [9 729], [729 59040], [59040 4781511], [4781511 387243351], [387243351 31361929920]\n(a^2 + b^2) / (1 + ab) = 10^2 has solutions: [10 1000], [1000 99990], [99990 9998000], [9998000 999700010], [999700010 99960003000]\n"
  },
  {
    "path": "Math/length_of_shortest_addition_chain.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 17 August 2016\n# Website: https://github.com/trizen\n\n# Length of shortest addition chain for n.\n# Equivalently, the minimal number of multiplications required to compute n-th power.\n\n# See also: https://oeis.org/A003313\n#           https://projecteuler.net/problem=122\n\n# (this algorithm is not efficient for n >= 35)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse List::Util qw(min);\n\nsub mk {\n    my ($n, $k, $pos, @nums) = @_;\n\n    return 'inf'  if $n > $k;\n    return 'inf'  if $pos > $#nums;\n    return $#nums if $n == $k;\n\n    min(\n        mk($n, $k, $pos + 1, @nums),\n        mk($n + $nums[$pos], $k, $pos, @nums, $n + $nums[$pos])\n    );\n}\n\nfor my $k (1 .. 10) {\n    my $r = mk(1, $k, 0, 1);\n    say \"mk($k) = \", $r;\n}\n"
  },
  {
    "path": "Math/lerch_zeta_function.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 03 January 2018\n# https://github.com/trizen\n\n# Simple implementation of the Lerch zeta function Φ(z, s, t), for real(z) < 1/2.\n\n# Formula due to Guillera and Sondow (2005).\n\n# See also:\n#   https://mathworld.wolfram.com/LerchTranscendent.html\n#   https://en.wikipedia.org/wiki/Lerch_zeta_function\n\nuse 5.020;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload pi binomial factorial);\n\nsub lerch ($z, $s, $t, $reps = 100) {\n    my $sum = 0.0;\n\n    my $r = (-$z) / (1 - $z);\n\n    foreach my $n (0 .. $reps) {\n\n        my $temp = 0.0;\n\n        foreach my $k (0 .. $n) {\n            $temp += (-1)**$k * binomial($n, $k) * ($t + $k)**(-$s);\n        }\n\n        $sum += $r**$n * $temp;\n    }\n\n    $sum / (1 - $z);\n}\n\nsay \"zeta(2)/2 =~ \", lerch(-1, 2, 1);        # 0.822467033424113...\nsay \"4*catalan =~ \", lerch(-1, 2, 1 / 2);    # 3.663862376708876...\n\nsay '';\n\nsub A281964 ($n) {\n    (factorial($n) * (-2 * i * i**$n * (lerch(-1, 1, $n / 2 + 1) - i * lerch(-1, 1, ($n + 1) / 2)) + pi + 2 * i * log(2)) / 4)->real->round;\n}\n\nforeach my $n (1 .. 10) {\n    printf(\"a(%2d) = %s\\n\", $n, A281964($n));\n}\n"
  },
  {
    "path": "Math/logarithmic_integral_asymptotic_formula.pl",
    "content": "#!/usr/bin/perl\n\n# Very good asymptotic formula for Li(x), due to Cesaro.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(factorial);\n\nmy $x = 1e9;\n\nmy $sum = 0;\nforeach my $n (1 .. log($x)) {\n    $sum += factorial($n - 1) * $x / log($x)**$n;\n}\nsay $sum;    #=> 50849234.742179\n"
  },
  {
    "path": "Math/logarithmic_root.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 17 July 2016\n# Website: https://github.com/trizen\n\n# Logarithmic root of n.\n\n# Solves c = x^x, where \"c\" is known.\n# (based on Newton's method for the nth-root)\n\n# Example: 100 = x^x\n#          x = lgrt(100)\n#          x =~ 3.59728502354042\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload);\n\nsub lgrt {\n    my ($c) = @_;\n\n    my $p = 1 / 10**($Math::AnyNum::PREC >> 2);\n    my $d = log($c);\n\n    my $x = 1;\n    my $y = 0;\n\n    while (abs($x - $y) > $p) {\n        $y = $x;\n        $x = ($x + $d) / (1 + log($x));\n    }\n\n    $x;\n}\n\nsay lgrt( 100);   # 3.59728502354041750549765225178228606913554305489\nsay lgrt(-100);   # 3.70202936660214594290193962952737102802777010583+1.34823128471151901327831464969872480416292147614i\n"
  },
  {
    "path": "Math/logarithmic_root_complex.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 17 September 2016\n# Website: https://github.com/trizen\n\n# Logarithmic root of n.\n# Solves c = x^x, where \"c\" is known.\n# (based on Newton's method for nth-root)\n\n# Example: 100 = x^x\n#          x = lgrt(100)\n#          x =~ 3.59728502354042\n\n# The function is defined in complex numbers for any value != 0.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::MPC;\nuse Math::MPFR;\n\nmy $PREC  = 128;                      # can be tweaked\nmy $ROUND = Math::MPC::MPC_RNDNN();\n\nsub lgrt {\n    my ($c) = @_;\n\n    if (ref($c) ne 'Math::MPC') {\n        my $n = Math::MPC::Rmpc_init2($PREC);\n        Math::MPC::Rmpc_set_str($n, \"$c\", 10, $ROUND);\n        $c = $n;\n    }\n\n    my $p = Math::MPFR::Rmpfr_init2($PREC);\n    Math::MPFR::Rmpfr_ui_pow_ui($p, 10, $PREC >> 2, $ROUND);\n    Math::MPFR::Rmpfr_ui_div($p, 1, $p, $ROUND);\n\n    my $d = Math::MPC::Rmpc_init2($PREC);\n    Math::MPC::Rmpc_log($d, $c, $ROUND);\n\n    my $x = Math::MPC::Rmpc_init2($PREC);\n    Math::MPC::Rmpc_set($x, $c, $ROUND);\n    Math::MPC::Rmpc_sqrt($x, $x, $ROUND);\n    Math::MPC::Rmpc_add_ui($x, $x, 1, $ROUND);\n    Math::MPC::Rmpc_log($x, $x, $ROUND);\n\n    my $y = Math::MPC::Rmpc_init2($PREC);\n    Math::MPC::Rmpc_set_ui($y, 0, $ROUND);\n\n    my $tmp = Math::MPC::Rmpc_init2($PREC);\n    my $abs = Math::MPFR::Rmpfr_init2($PREC);\n\n    my $count = 0;\n    while (1) {\n        Math::MPC::Rmpc_sub($tmp, $x, $y, $ROUND);\n        Math::MPC::Rmpc_abs($abs, $tmp, $ROUND);\n        Math::MPFR::Rmpfr_cmp($abs, $p) <= 0 and last;\n\n        Math::MPC::Rmpc_set($y, $x, $ROUND);\n\n        Math::MPC::Rmpc_log($tmp, $x, $ROUND);\n        Math::MPC::Rmpc_add_ui($tmp, $tmp, 1, $ROUND);\n\n        Math::MPC::Rmpc_add($x, $x, $d, $ROUND);\n        Math::MPC::Rmpc_div($x, $x, $tmp, $ROUND);\n        last if ++$count > $PREC;\n    }\n\n    $x;\n}\n\nsay lgrt(100);     # (3.597285023540417505497652251782286069146 0)\nsay lgrt(-100);    # (3.702029366602145942901939629527371028025 1.34823128471151901327831464969872480416)\nsay lgrt(-1);      # (1.690386757163589211290419139332364873691 1.869907964026775775222799239924290781916)\n"
  },
  {
    "path": "Math/logarithmic_root_in_two_variables.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 05 July 2017\n# https://github.com/trizen\n\n# An interesting function: logarithmic root in two variables.\n\n# For certain values of x, it has the following identity:\n#   lgrt2(x, x) = lgrt(x)\n\n# such that:\n#   exp(log(lgrt(x)) * lgrt(x)) = x\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload pi e EulerGamma);\n\nsub lgrt2 {\n    my ($n, $k) = @_;\n\n    my $f = log($n);\n    my $d = log($k);\n\n    my $r = sqrt($f * $d);\n\n    for (1 .. 200) {\n\n        my $x = exp($f / $r);\n        my $y = $d / log($x);\n\n        $r = sqrt($x * $y);\n    }\n\n    return $r;\n}\n\nsay lgrt2(pi, e);                     # 1.70771856994915347630915983730048900477178427941\nsay lgrt2(e,  pi);                    # 1.92464943796370515962751401131903762619866583525\n\nsay lgrt2(exp(EulerGamma), e);             # 2.24133450569957655907533525796185668012280055007\nsay lgrt2(e,          exp(EulerGamma));    # 1.26917997775582192005119311046938840265836794516\n\nsay lgrt2(exp(EulerGamma), pi);            # 2.49858594291645763243658930518886102264912661091\nsay lgrt2(pi,         exp(EulerGamma));    # 1.25519152681721226553799617023948749426608115087\n\nsay lgrt2(100, 100);                  # 3.59728502354041750549765225178228606913554305489\n\nsay lgrt2(i,  -1);                    # 2.32604988653472423641885139636547364864085030537+1.30957380904696411943253549742370685112065954665i\nsay lgrt2(-1, i);                     # 1.10679171296146730411561900792354747210041425159+1.55699997420064988554089005455614440858763281837i\n"
  },
  {
    "path": "Math/logarithmic_root_mpfr.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 17 September 2016\n# Website: https://github.com/trizen\n\n# Logarithmic root of n.\n# Solves c = x^x, where \"c\" is known.\n# (based on Newton's method for nth-root)\n\n# Example: 100 = x^x\n#          x = lgrt(100)\n#          x =~ 3.59728502354042\n\n# The function is defined in real numbers for any value >= 0.7\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::MPFR;\n\nmy $PREC  = 128;                       # can be tweaked\nmy $ROUND = Math::MPFR::MPFR_RNDN();\n\nsub lgrt {\n    my ($c) = @_;\n\n    if (ref($c) ne 'Math::MPFR') {\n        my $n = Math::MPFR::Rmpfr_init2($PREC);\n        Math::MPFR::Rmpfr_set_str($n, \"$c\", 10, $ROUND);\n        $c = $n;\n    }\n\n    my $p = Math::MPFR::Rmpfr_init2($PREC);\n    Math::MPFR::Rmpfr_ui_pow_ui($p, 10, $PREC >> 2, $ROUND);\n    Math::MPFR::Rmpfr_ui_div($p, 1, $p, $ROUND);\n\n    my $d = Math::MPFR::Rmpfr_init2($PREC);\n    Math::MPFR::Rmpfr_log($d, $c, $ROUND);\n\n    my $x = Math::MPFR::Rmpfr_init2($PREC);\n    Math::MPFR::Rmpfr_set_ui($x, 1, $ROUND);\n\n    my $y = Math::MPFR::Rmpfr_init2($PREC);\n    Math::MPFR::Rmpfr_set_ui($y, 0, $ROUND);\n\n    my $tmp = Math::MPFR::Rmpfr_init2($PREC);\n\n    while (1) {\n        Math::MPFR::Rmpfr_sub($tmp, $x, $y, $ROUND);\n        Math::MPFR::Rmpfr_cmpabs($tmp, $p) <= 0 and last;\n\n        Math::MPFR::Rmpfr_set($y, $x, $ROUND);\n\n        Math::MPFR::Rmpfr_log($tmp, $x, $ROUND);\n        Math::MPFR::Rmpfr_add_ui($tmp, $tmp, 1, $ROUND);\n\n        Math::MPFR::Rmpfr_add($x, $x, $d, $ROUND);\n        Math::MPFR::Rmpfr_div($x, $x, $tmp, $ROUND);\n    }\n\n    $x;\n}\n\nsay lgrt(100);    # 3.597285023540417505497652251782286069146\n"
  },
  {
    "path": "Math/long_division.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 24 December 2012\n# https://github.com/trizen\n\n# Long division with arbitrary precision.\n\nuse 5.016;\nuse strict;\nuse warnings;\n\nsub divide ($$$) {\n    my ($x, $y, $f, $z) = @_;\n\n    my $c = 0;\n    sub {\n        my $i = int($x / $y);\n\n        $z .= $i;\n        $x -= $y * $i;\n\n        my $s = -1;\n        until ($x >= $y) { $x *= 10; ++$s; $x || last }\n\n        $z .= '.' if !$c;\n        $z .= '0' x $s;\n        $c += $s + 1;\n\n        __SUB__->() if $c <= $f;\n      }\n      ->();\n\n    return $z;\n}\n\nsay divide(634,  212,   64);\nsay divide(9,    379,   64);\nsay divide(42.5, 232.7, 64);\n\nsay divide(7246,8743,64);\n"
  },
  {
    "path": "Math/long_multiplication.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 09 July 2015\n# Website: https://github.com/trizen\n\n# A creative algorithm for arbitrary long integer multiplication.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse integer;\nuse List::Util qw(sum);\n\nsub long_multiplication {\n    my ($x, $y) = @_;\n\n    use integer;\n    if (length($x) < length($y)) {\n        ($y, $x) = ($x, $y);\n    }\n\n    if ($x eq '0' or $y eq '0') {\n        return '0';\n    }\n\n    my @x = reverse split //, $x;\n    my @y = reverse split //, $y;\n\n    my $xlen = $#x;\n    my $ylen = $#y;\n\n    my @map;\n    my $mem = 0;\n\n    foreach my $j (0 .. $ylen) {\n        foreach my $i (0 .. $xlen) {\n            my $n = $x[$i] * $y[$j] + $mem;\n\n            if ($i == $xlen) {\n                push @{$map[$j]}, $n % 10, $n / 10;\n                $mem = 0;\n            }\n            else {\n                push @{$map[$j]}, $n % 10;\n                $mem = $n / 10;\n            }\n        }\n\n        my $n = $ylen - $j;\n        if ($n > 0) {\n            push @{$map[$j]}, ((0) x $n);\n        }\n\n        my $m = $ylen - $n;\n        if ($m > 0) {\n            unshift @{$map[$j]}, ((0) x $m);\n        }\n    }\n\n    my @result;\n    my @mrange = (0 .. $#map);\n    my $end    = $xlen + $ylen + 1;\n\n    foreach my $i (0 .. $end) {\n        my $n = sum(map { $map[$_][$i] } @mrange) + $mem;\n\n        if ($i == $end) {\n            push @result, $n if $n != 0;\n        }\n        else {\n            push @result, $n % 10;\n            $mem = $n / 10;\n        }\n    }\n\n    return join('', reverse @result);\n}\n\nsay long_multiplication('37975227936943673922808872755445627854565536638199',\n                        '40094690950920881030683735292761468389214899724061');\n"
  },
  {
    "path": "Math/lucas-carmichael_numbers_from_multiple.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 08 March 2023\n# https://github.com/trizen\n\n# Generate Lucas-Carmichael numbers from a given multiple.\n\n# See also:\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory qw(:all);\n\nsub lucas_carmichael_from_multiple ($m, $callback) {\n\n    is_square_free($m) || return;\n\n    my $L = lcm(map { addint($_, 1) } factor($m));\n    my $v = mulmod(invmod($m, $L) // (return), -1, $L);\n\n    for (my $p = $v ; ; $p += $L) {\n\n        gcd($m, $p) == 1 or next;\n\n        my @factors = factor_exp($p);\n        (vecall { $_->[1] == 1 } @factors) || next;\n\n        my $n = $m * $p;\n        my $l = lcm(map { addint($_->[0], 1) } @factors);\n\n        if (($n + 1) % $l == 0) {\n            $callback->($n);\n        }\n    }\n}\n\nlucas_carmichael_from_multiple(11 * 17, sub ($n) { say $n });\n"
  },
  {
    "path": "Math/lucas-carmichael_numbers_from_multiple_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 08 March 2023\n# https://github.com/trizen\n\n# Generate Lucas-Carmichael numbers from a given multiple.\n\n# See also:\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory qw(:all);\n\nsub lucas_carmichael_from_multiple ($m, $callback) {\n\n    my $t = Math::GMPz::Rmpz_init();\n    my $u = Math::GMPz::Rmpz_init();\n    my $v = Math::GMPz::Rmpz_init();\n\n    is_square_free($m) || return;\n\n    my $L = lcm(map { addint($_, 1) } factor($m));\n\n    $m = Math::GMPz->new(\"$m\");\n    $L = Math::GMPz->new(\"$L\");\n\n    Math::GMPz::Rmpz_invert($v, $m, $L) || return;\n    Math::GMPz::Rmpz_sub($v, $L, $v);\n\n    for (my $p = Math::GMPz::Rmpz_init_set($v) ; ; Math::GMPz::Rmpz_add($p, $p, $L)) {\n\n        Math::GMPz::Rmpz_gcd($t, $m, $p);\n        Math::GMPz::Rmpz_cmp_ui($t, 1) == 0 or next;\n\n        my @factors = factor_exp($p);\n        (vecall { $_->[1] == 1 } @factors) || next;\n\n        Math::GMPz::Rmpz_mul($v, $m, $p);\n        Math::GMPz::Rmpz_add_ui($u, $v, 1);\n\n        Math::GMPz::Rmpz_set_str($t, lcm(map { addint($_->[0], 1) } @factors), 10);\n\n        if (Math::GMPz::Rmpz_divisible_p($u, $t)) {\n            $callback->(Math::GMPz::Rmpz_init_set($v));\n        }\n    }\n}\n\nlucas_carmichael_from_multiple(11 * 17, sub ($n) { say $n });\n"
  },
  {
    "path": "Math/lucas-carmichael_numbers_in_range.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 27 August 2022\n# https://github.com/trizen\n\n# Generate all the Lucas-Carmichael numbers with n prime factors in a given range [a,b]. (not in sorted order)\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\n# PARI/GP program (in range [A,B]) (simple):\n#   lucas_carmichael(A, B, k) = A=max(A, vecprod(primes(k+1))\\2); (f(m, l, lo, k) = my(list=List()); my(hi=sqrtnint(B\\m, k)); if(lo > hi, return(list)); if(k==1, forprime(p=max(lo, ceil(A/m)), hi, my(t=m*p); if((t+1)%l == 0 && (t+1)%(p+1) == 0, listput(list, t))), forprime(p=lo, hi, if(gcd(m, p+1) == 1, list=concat(list, f(m*p, lcm(l, p+1), p+1, k-1))))); list); vecsort(Vec(f(1, 1, 3, k)));\n\n# PARI/GP program (in range [A, B]) (fast):\n#   lucas_carmichael(A, B, k) = A=max(A, vecprod(primes(k+1))\\2); my(max_p=sqrtint(B+1)-1); (f(m, l, lo, k) = my(list=List()); my(hi=min(max_p, sqrtnint(B\\m, k))); if(lo > hi, return(list)); if(k==1, lo=max(lo, ceil(A/m)); my(t=lift(-1/Mod(m,l))); while(t < lo, t += l); forstep(p=t, hi, l, if(isprime(p), my(n=m*p); if((n+1)%(p+1) == 0, listput(list, n)))), forprime(p=lo, hi, if(gcd(m, p+1) == 1, list=concat(list, f(m*p, lcm(l, p+1), p+1, k-1))))); list); vecsort(Vec(f(1, 1, 3, k)));\n\n# PARI/GP program to generate all the Lucas-Carmichael numbers <= n (fast):\n#   lucas_carmichael(A, B, k) = A=max(A, vecprod(primes(k+1))\\2); my(max_p=sqrtint(B+1)-1); (f(m, l, lo, k) = my(list=List()); my(hi=min(max_p, sqrtnint(B\\m, k))); if(lo > hi, return(list)); if(k==1, lo=max(lo, ceil(A/m)); my(t=lift(-1/Mod(m,l))); while(t < lo, t += l); forstep(p=t, hi, l, if(isprime(p), my(n=m*p); if((n+1)%(p+1) == 0, listput(list, n)))), forprime(p=lo, hi, if(gcd(m, p+1) == 1, list=concat(list, f(m*p, lcm(l, p+1), p+1, k-1))))); list); f(1, 1, 3, k);\n#   upto(n) = my(list=List()); for(k=3, oo, if(vecprod(primes(k+1))\\2 > n, break); list=concat(list, lucas_carmichael(1, n, k))); vecsort(Vec(list));\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\n\nsub lucas_carmichael_numbers_in_range ($A, $B, $k) {\n\n    $A = vecmax($A, pn_primorial($k));\n\n    # Largest possisble prime factor for Lucas-Carmichael numbers <= B\n    my $max_p = sqrtint($B);\n\n    my @list;\n\n    sub ($m, $L, $lo, $k) {\n\n        my $hi = rootint(divint($B, $m), $k);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        if ($k == 1) {\n\n            $hi = $max_p if ($hi > $max_p);\n            $lo = vecmax($lo, cdivint($A, $m));\n            $lo > $hi && return;\n\n            my $t = $L - invmod($m, $L);\n            $t > $hi && return;\n            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);\n\n            for (my $p = $t ; $p <= $hi ; $p += $L) {\n                if (($m * $p + 1) % ($p + 1) == 0 and is_prime($p)) {\n                    push @list, $m * $p;\n                }\n            }\n\n            return;\n        }\n\n        foreach my $p (@{primes($lo, $hi)}) {\n            if (gcd($m, $p + 1) == 1) {\n                __SUB__->($m * $p, lcm($L, $p + 1), $p + 1, $k - 1);\n            }\n        }\n      }\n      ->(1, 1, 3, $k);\n\n    return sort { $a <=> $b } @list;\n}\n\n# Generate all the Lucas-Carmichael numbers with 5 prime factors in the range [100, 10^8]\n\nmy $k    = 5;\nmy $from = 100;\nmy $upto = 1e8;\n\nmy @arr = lucas_carmichael_numbers_in_range($from, $upto, $k);\nsay join(', ', @arr);\n\n__END__\n588455, 1010735, 2276351, 2756159, 4107455, 4874639, 5669279, 6539819, 8421335, 13670855, 16184663, 16868159, 21408695, 23176439, 24685199, 25111295, 26636687, 30071327, 34347599, 34541639, 36149399, 36485015, 38999519, 39715319, 42624911, 43134959, 49412285, 49591919, 54408959, 54958799, 57872555, 57953951, 64456223, 66709019, 73019135, 77350559, 78402815, 82144799, 83618639, 86450399, 93277079, 96080039, 98803439\n"
  },
  {
    "path": "Math/lucas-carmichael_numbers_in_range_from_prime_factors.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 24 September 2022\n# https://github.com/trizen\n\n# Generate all the Lucas-Carmichael numbers with n prime factors in a given range [A,B], using a given list of prime factors. (not in sorted order)\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\nuse List::Util qw(uniq);\n\nsub lucas_carmichael_numbers_in_range ($A, $B, $k, $primes, $callback) {\n\n    $A = vecmax($A, pn_primorial($k));\n\n    # Largest possisble prime factor for Lucas-Carmichael numbers <= B\n    my $max_p = sqrtint($B);\n\n    my @P   = sort { $a <=> $b } grep { $_ <= $max_p } uniq(@$primes);\n    my $end = $#P;\n\n    sub ($m, $lambda, $j, $k) {\n\n        my $y = vecmin($max_p, rootint(divint($B, $m), $k));\n\n        if ($k == 1) {\n\n            my $x = cdivint($A, $m);\n\n            if ($P[-1] < $x) {\n                return;\n            }\n\n            foreach my $i ($j .. $end) {\n                my $p = $P[$i];\n\n                last if ($p > $y);\n                next if ($p < $x);\n\n                my $t = $m * $p;\n\n                if (($t + 1) % $lambda == 0 and ($t + 1) % ($p + 1) == 0) {\n                    $callback->($t);\n                }\n            }\n\n            return;\n        }\n\n        foreach my $i ($j .. $end) {\n            my $p = $P[$i];\n            last if ($p > $y);\n\n            gcd($m, $p + 1) == 1 or next;\n\n            # gcd($m*$p, divisor_sum($m*$p)) == 1 or die \"$m*$p: not Lucas-cyclic\";\n\n            __SUB__->($m * $p, lcm($lambda, $p + 1), $i + 1, $k - 1);\n        }\n      }\n      ->(1, 1, 0, $k);\n}\n\nmy $lambda = 5040;\nmy @primes = grep { $_ > 2 and $lambda % $_ != 0 and is_prime($_) } map { $_ - 1 } divisors($lambda);\n\nforeach my $k (3 .. 6) {\n    my @arr;\n    lucas_carmichael_numbers_in_range(1, 10**(2 * $k), $k, \\@primes, sub ($n) { push @arr, $n });\n    say \"$k: \", join(', ', sort { $a <=> $b } @arr);\n}\n\n__END__\n3: 20999, 46079, 63503, 76751, 88559, 152279, 155819, 230159, 388079, 761039\n4: 81719, 357599, 895679, 1097459, 2150819, 2193119, 2581319, 3228119, 6023039, 8159759, 9349919, 12791519, 14800799, 18119519, 21490919, 38534327, 64585079\n5: 6539819, 34541639, 49591919, 77350559, 83618639, 96080039, 157169879, 164613599, 183259439, 190079567, 307409759, 308810879, 690313679, 715317119, 728655479, 1053082799, 1122191279, 1170131759, 1206682559, 1459340639, 1532480543, 1763936999, 2049702479, 2159807159, 2576523599, 2596839839, 3641725079, 3986123399, 4038577199, 4358632319, 5165929439, 5206299839, 5424849359, 6709316039, 7418764079, 8177790599, 8897595839, 9578393999\n6: 577901519, 1361371679, 1373537759, 1638550199, 2828024639, 2888673983, 2928121559, 3080459759, 4805735759, 4864901327, 5287495499, 5800236959, 6416323199, 7437699359, 7867853279, 9779978879, 11550463679, 11672334239, 13356002519, 13425488999, 14413764959, 15123923639, 15211879199, 15444409679, 15562456559, 16386375599, 17095979879, 17510861339, 17959287359, 17965888919, 19178943839, 19621223999, 20078753519, 21093389999, 23231683439, 23998272479, 25648570079, 26311503959, 29161838879, 29812502159, 32093601119, 39033948239, 41340843599, 46096729559, 52810178399, 52915495919, 54527266079, 61450169759, 62065553759, 70523812799, 71361474239, 79214320079, 81732797999, 90622974959, 92296542239, 99952937279, 102454676519, 120477765239, 126759626279, 128758238279, 137991228479, 138213779759, 142528198679, 146361334559, 148323320279, 149896068839, 153340029359, 158221682639, 159322390559, 159890779439, 160255240739, 161112901319, 171015667199, 173334520799, 180069704639, 180965337839, 187380048239, 202229818559, 206865082619, 220211424719, 222446579039, 232442534519, 233155551599, 253483070399, 296032324559, 297059797439, 307853073359, 343190741039, 353042872559, 363624130799, 380506890959, 385801834319, 392952329279, 399641253479, 405417742379, 412826561279, 487915989119, 509234910239, 521538610319, 522204006239, 589571193959, 648004578479, 654467622479, 675275252399, 741269849039, 745580820599, 756101062079, 784130932079, 792545816159, 806516068679, 823432111199, 827953257599, 837926369279, 854535596039, 906105710159\n"
  },
  {
    "path": "Math/lucas-carmichael_numbers_in_range_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 23 February 2023\n# https://github.com/trizen\n\n# Generate all the Lucas-Carmichael numbers with n prime factors in a given range [a,b]. (not in sorted order)\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\n# PARI/GP program (up to n):\n#   upto(n, k) = my(A=vecprod(primes(k+1))\\2, B=n); (f(m, l, p, k, u=0, v=0) = my(list=List()); if(k==1, forprime(p=u, v, my(t=m*p); if((t+1)%l == 0 && (t+1)%(p+1) == 0, listput(list, t))), forprime(q = p, sqrtnint(B\\m, k), my(t = m*q); my(L=lcm(l, q+1)); if(gcd(L, t) == 1, my(u=ceil(A/t), v=B\\t); if(u <= v, my(r=nextprime(q+1)); if(k==2 && r>u, u=r); list=concat(list, f(t, L, r, k-1, u, v)))))); list); vecsort(Vec(f(1, 1, 3, k)));\n\n# PARI/GP program (in range [A, B]):\n#   lucas_carmichael(A, B, k) = A=max(A, vecprod(primes(k+1))\\2); (f(m, l, lo, k) = my(list=List()); my(hi=sqrtnint(B\\m, k)); if(lo > hi, return(list)); if(k==1, lo=max(lo, ceil(A/m)); my(t=lift(-1/Mod(m,l))); while(t < lo, t += l); forstep(p=t, hi, l, if(isprime(p), my(n=m*p); if((n+1)%(p+1) == 0, listput(list, n)))), forprime(p=lo, hi, if(gcd(m, p+1) == 1, list=concat(list, f(m*p, lcm(l, p+1), p+1, k-1))))); list); vecsort(Vec(f(1, 1, 3, k)));\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory 0.74 qw(:all);\n\nsub lucas_carmichael_numbers_in_range ($A, $B, $k) {\n\n    $A = vecmax($A, pn_primorial($k + 1) >> 1);\n\n    $A = Math::GMPz->new(\"$A\");\n    $B = Math::GMPz->new(\"$B\");\n\n    my $u = Math::GMPz::Rmpz_init();\n    my $v = Math::GMPz::Rmpz_init();\n\n    # max_p = floor(sqrt(B))\n    my $max_p = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_sqrt($max_p, $B);\n    $max_p = Math::GMPz::Rmpz_get_ui($max_p) if Math::GMPz::Rmpz_fits_ulong_p($max_p);\n\n    my @list;\n\n    sub ($m, $L, $lo, $k) {\n\n        Math::GMPz::Rmpz_tdiv_q($u, $B, $m);\n        Math::GMPz::Rmpz_root($u, $u, $k);\n\n        Math::GMPz::Rmpz_fits_ulong_p($u) || die \"Too large value!\";\n\n        my $hi = Math::GMPz::Rmpz_get_ui($u);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        if ($k == 1) {\n\n            $hi = $max_p if ($max_p < $hi);\n            Math::GMPz::Rmpz_cdiv_q($u, $A, $m);\n\n            if (Math::GMPz::Rmpz_fits_ulong_p($u)) {\n                $lo = vecmax($lo, Math::GMPz::Rmpz_get_ui($u));\n            }\n            elsif (Math::GMPz::Rmpz_cmp_ui($u, $lo) > 0) {\n                if (Math::GMPz::Rmpz_cmp_ui($u, $hi) > 0) {\n                    return;\n                }\n                $lo = Math::GMPz::Rmpz_get_ui($u);\n            }\n\n            if ($lo > $hi) {\n                return;\n            }\n\n            Math::GMPz::Rmpz_invert($v, $m, $L);\n            Math::GMPz::Rmpz_sub($v, $L, $v);\n\n            if (Math::GMPz::Rmpz_cmp_ui($v, $hi) > 0) {\n                return;\n            }\n\n            if (Math::GMPz::Rmpz_fits_ulong_p($L)) {\n                $L = Math::GMPz::Rmpz_get_ui($L);\n            }\n\n            my $t = Math::GMPz::Rmpz_get_ui($v);\n            $t > $hi && return;\n            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);\n\n            for (my $p = $t ; $p <= $hi ; $p += $L) {\n                if (is_prime($p)) {\n                    Math::GMPz::Rmpz_mul_ui($v, $m, $p);\n                    Math::GMPz::Rmpz_add_ui($u, $v, 1);\n                    if (Math::GMPz::Rmpz_divisible_ui_p($u, $p + 1)) {\n                        push @list, Math::GMPz::Rmpz_init_set($v);\n                    }\n                }\n            }\n\n            return;\n        }\n\n        my $z   = Math::GMPz::Rmpz_init();\n        my $lcm = Math::GMPz::Rmpz_init();\n\n        foreach my $p (@{primes($lo, $hi)}) {\n\n            Math::GMPz::Rmpz_gcd_ui($Math::GMPz::NULL, $m, $p + 1) == 1 or next;\n            Math::GMPz::Rmpz_lcm_ui($lcm, $L, $p + 1);\n            Math::GMPz::Rmpz_mul_ui($z, $m, $p);\n\n            __SUB__->($z, $lcm, $p + 1, $k - 1);\n        }\n      }\n      ->(Math::GMPz->new(1), Math::GMPz->new(1), 3, $k);\n\n    return sort { $a <=> $b } @list;\n}\n\n# Generate all the Lucas-Carmichael numbers with 5 prime factors in the range [100, 10^8]\n\nmy $k    = 5;\nmy $from = 100;\nmy $upto = 1e8;\n\nmy @arr = lucas_carmichael_numbers_in_range($from, $upto, $k);\nsay join(', ', @arr);\n\n__END__\n588455, 1010735, 2276351, 2756159, 4107455, 4874639, 5669279, 6539819, 8421335, 13670855, 16184663, 16868159, 21408695, 23176439, 24685199, 25111295, 26636687, 30071327, 34347599, 34541639, 36149399, 36485015, 38999519, 39715319, 42624911, 43134959, 49412285, 49591919, 54408959, 54958799, 57872555, 57953951, 64456223, 66709019, 73019135, 77350559, 78402815, 82144799, 83618639, 86450399, 93277079, 96080039, 98803439\n"
  },
  {
    "path": "Math/lucas-miller_factorization_method.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 07 January 2020\n# https://github.com/trizen\n\n# A simple factorization method, using the Lucas `U_n(P,Q)` sequences.\n# Inspired by the Miller-Rabin factorization method.\n\n# Works best on Lucas pseudoprimes.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Lucas_pseudoprime\n#   https://en.wikipedia.org/wiki/Miller-Rabin_primality_test\n\nuse 5.020;\nuse warnings;\n\nuse Math::GMPz;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub lucas_miller_factor ($n, $j = 1, $k = 100) {\n\n    if (ref($n) ne 'Math::GMPz') {\n        $n = Math::GMPz->new(\"$n\");\n    }\n\n    my $D = $n + $j;\n    my $s = valuation($D, 2);\n    my $r = $s - 1;\n    my $d = $D >> $s;\n\n    foreach my $i (1 .. $k) {\n\n        my $P = vecmin(1 + int(rand(1e6)), urandomm($n));\n        my $Q = vecmin(1 + int(rand(1e6)), urandomm($n));\n\n        $Q *= -1 if (rand(1) < 0.5);\n\n        next if is_square($P * $P - 4 * $Q);\n\n        my ($U, $V, $T) = lucas_sequence($n, $P, $Q, $d);\n\n        foreach my $z (0 .. $r) {\n\n            foreach my $g (gcd($U, $n), gcd($V, $n), gcd(subint($V, $P), $n)) {\n                if ($g > 1 and $g < $n) {\n                    return $g;\n                }\n            }\n\n            $U = mulmod($U, $V, $n);\n            $V = mulmod($V, $V, $n);\n            $V = submod($V, addint($T, $T), $n);\n            $T = mulmod($T, $T, $n);\n        }\n    }\n\n    return 1;\n}\n\nsay lucas_miller_factor(\"16641689036184776955112478816668559\");\nsay lucas_miller_factor(\"17350074279723825442829581112345759\");\nsay lucas_miller_factor(\"61881629277526932459093227009982733523969186747\");\nsay lucas_miller_factor(\"122738580838512721992324860157572874494433031849\", -1);\nsay lucas_miller_factor(\"181490268975016506576033519670430436718066889008242598463521\");\nsay lucas_miller_factor(\"173315617708997561998574166143524347111328490824959334367069087\");\nsay lucas_miller_factor(\"57981220983721718930050466285761618141354457135475808219583649146881\");\nsay lucas_miller_factor(\"2425361208749736840354501506901183117777758034612345610725789878400467\");\nsay lucas_miller_factor(\"131754870930495356465893439278330079857810087607720627102926770417203664110488210785830750894645370240615968198960237761\");\n"
  },
  {
    "path": "Math/lucas-pocklington_primality_proving.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 10 January 2020\n# https://github.com/trizen\n\n# Prove the primality of a number N, using the Lucas `U` sequence and the Pocklington primality test, recursively factoring N-1 and N+1 (whichever is easier to factorize first).\n\n# See also:\n#   https://en.wikipedia.org/wiki/Pocklington_primality_test\n#   https://en.wikipedia.org/wiki/Primality_certificate\n#   https://mathworld.wolfram.com/PrattCertificate.html\n#   https://math.stackexchange.com/questions/663341/n1-primality-proving-is-slow\n\nuse 5.020;\nuse strict;\nuse warnings;\nuse experimental qw(signatures);\n\nuse List::Util qw(uniq);\nuse ntheory qw(is_prime is_prob_prime);\nuse Math::Prime::Util::GMP qw(ecm_factor is_strong_pseudoprime);\n\nuse Math::AnyNum qw(\n  :overload prod primorial is_coprime powmod\n  irand min is_square lucasUmod gcd kronecker\n  );\n\nmy $TRIAL_LIMIT = 10**6;\nmy $primorial   = primorial($TRIAL_LIMIT);\n\nsub trial_factor ($n) {\n\n    my @f;\n    my $g = gcd($primorial, $n);\n\n    if ($g > 1) {\n        my @primes = ntheory::factor($g);\n        foreach my $p (@primes) {\n            while ($n % $p == 0) {\n                push @f, $p;\n                $n /= $p;\n            }\n        }\n    }\n\n    return ($n, @f);\n}\n\nsub lucas_pocklington_primality_proving ($n, $lim = 2**64) {\n\n    if ($n <= $lim or $n <= 2) {\n        return is_prime($n);    # fast deterministic test for small n\n    }\n\n    is_prob_prime($n) || return 0;\n\n    if (ref($n) ne 'Math::AnyNum') {\n        $n = Math::AnyNum->new(\"$n\");\n    }\n\n    my $nm1 = $n - 1;\n    my $np1 = $n + 1;\n\n    my ($B1, @f1) = trial_factor($nm1);\n    my ($B2, @f2) = trial_factor($np1);\n\n    if (prod(@f1) < $B1 and prod(@f2) < $B2) {\n        if ($B1 < $B2) {\n            if (__SUB__->($B1)) {\n                push @f1, $B1;\n                $B1 = 1;\n            }\n            elsif (__SUB__->($B2)) {\n                push @f2, $B2;\n                $B2 = 1;\n            }\n        }\n        else {\n            if (__SUB__->($B2)) {\n                push @f2, $B2;\n                $B2 = 1;\n            }\n            elsif (__SUB__->($B1)) {\n                push @f1, $B1;\n                $B1 = 1;\n            }\n        }\n    }\n\n    my $pocklington_primality_proving = sub {\n\n        foreach my $p (uniq(@f1)) {\n            for (; ;) {\n                my $a = irand(2, $nm1);\n                is_strong_pseudoprime($n, $a) || return 0;\n                if (is_coprime(powmod($a, $nm1 / $p, $n) - 1, $n)) {\n                    say \"a = $a ; p = $p\";\n                    last;\n                }\n            }\n        }\n\n        return 1;\n    };\n\n    my $find_PQD = sub {\n\n        my $l = min(10**9, $n - 1);\n\n        for (; ;) {\n            my $P = (irand(1, $l));\n            my $Q = (irand(1, $l) * ((rand(1) < 0.5) ? 1 : -1));\n            my $D = ($P * $P - 4 * $Q);\n\n            next if is_square($D % $n);\n            next if ($P >= $n);\n            next if ($Q >= $n);\n            next if (kronecker($D, $n) != -1);\n\n            return ($P, $Q, $D);\n        }\n    };\n\n    my $lucas_primality_proving = sub {\n        my ($P, $Q, $D) = $find_PQD->();\n\n        is_strong_pseudoprime($n, $P + 1) or return 0;\n        lucasUmod($P, $Q, $np1, $n) == 0  or return 0;\n\n        foreach my $p (uniq(@f2)) {\n            for (; ;) {\n                $D == ($P * $P - 4 * $Q) or die \"error: $P^2 - 4*$Q != $D\";\n\n                if ($P >= $n or $Q >= $n) {\n                    return __SUB__->();\n                }\n\n                if (is_coprime(lucasUmod($P, $Q, $np1 / $p, $n), $n)) {\n                    say \"P = $P ; Q = $Q ; p = $p\";\n                    last;\n                }\n\n                ($P, $Q) = ($P + 2, $P + $Q + 1);\n                is_strong_pseudoprime($n, $P) || return 0;\n            }\n        }\n\n        return 1;\n    };\n\n    for (; ;) {\n        my $A1 = prod(@f1);\n        my $A2 = prod(@f2);\n\n        if ($A1 > $B1 and is_coprime($A1, $B1)) {\n            say \"\\n:: N-1 primality proving of: $n\";\n            return $pocklington_primality_proving->();\n        }\n\n        if ($A2 > $B2 and is_coprime($A2, $B2)) {\n            say \"\\n:: N+1 primality proving of: $n\";\n            return $lucas_primality_proving->();\n        }\n\n        my @ecm_factors = map { Math::AnyNum->new($_) } ecm_factor($B1 * $B2);\n\n        foreach my $p (@ecm_factors) {\n\n            if ($B1 % $p == 0 and __SUB__->($p, $lim)) {\n                while ($B1 % $p == 0) {\n                    push @f1, $p;\n                    $A1 *= $p;\n                    $B1 /= $p;\n                }\n                if (__SUB__->($B1, $lim)) {\n                    push @f1, $B1;\n                    $A1 *= $B1;\n                    $B1 /= $B1;\n                }\n                last if ($A1 > $B1);\n            }\n\n            if ($B2 % $p == 0 and __SUB__->($p, $lim)) {\n                while ($B2 % $p == 0) {\n                    push @f2, $p;\n                    $A2 *= $p;\n                    $B2 /= $p;\n                }\n                if (__SUB__->($B2, $lim)) {\n                    push @f2, $B2;\n                    $A2 *= $B2;\n                    $B2 /= $B2;\n                }\n                last if ($A2 > $B2);\n            }\n        }\n    }\n}\n\nsay \"Is prime: \",\n  lucas_pocklington_primality_proving(115792089237316195423570985008687907853269984665640564039457584007913129603823);\n\n__END__\n:: N+1 primality proving of: 924116845936603030416149\nP = 446779227 ; Q = -570813692 ; p = 2\nP = 446779229 ; Q = -124034464 ; p = 3\nP = 446779229 ; Q = -124034464 ; p = 5\nP = 446779229 ; Q = -124034464 ; p = 23\nP = 446779229 ; Q = -124034464 ; p = 839\nP = 446779229 ; Q = -124034464 ; p = 319260971804461153\n\n:: N-1 primality proving of: 145206169609764066844927343258645146513471\na = 65398207550754611976310922745879907064270 ; p = 2\na = 4798691037244889621933820261318904161487 ; p = 3\na = 116906491330255234184370825424228431344076 ; p = 5\na = 136169406264815751493129123529048530997722 ; p = 13\na = 135944141295463967893304597786628217140508 ; p = 37\na = 97262888879650744356761188900815226887264 ; p = 5419\na = 2902916905620381183086755524953265942224 ; p = 2009429159\na = 107195181666607031025002747775812085643863 ; p = 924116845936603030416149\n\n:: N-1 primality proving of: 767990784468614637092681680819989903265059687929\na = 603854703399300341344639520448381233631361828843 ; p = 2\na = 107195257716196052909052603688672743914499334958 ; p = 661121\na = 138452952948919213705556701864021372614716309358 ; p = 145206169609764066844927343258645146513471\n\n:: N+1 primality proving of: 1893865274499603695070553024902095101451637190432913\nP = 903800454 ; Q = 701295878 ; p = 2\nP = 903800454 ; Q = 701295878 ; p = 3\nP = 903800454 ; Q = 701295878 ; p = 137\nP = 903800454 ; Q = 701295878 ; p = 767990784468614637092681680819989903265059687929\n\n:: N+1 primality proving of: 57896044618658097711785492504343953926634992332820282019728792003956564801911\nP = 263931529 ; Q = -357766694 ; p = 2\nP = 263931529 ; Q = -357766694 ; p = 3\nP = 263931529 ; Q = -357766694 ; p = 1669\nP = 263931529 ; Q = -357766694 ; p = 14083\nP = 263931529 ; Q = -357766694 ; p = 1857767\nP = 263931529 ; Q = -357766694 ; p = 29170630189\nP = 263931529 ; Q = -357766694 ; p = 1893865274499603695070553024902095101451637190432913\n\n:: N-1 primality proving of: 115792089237316195423570985008687907853269984665640564039457584007913129603823\na = 4029039168562415669306341971162211721541916673211300492678829534769579647404 ; p = 2\na = 56569963885874630697971498050698415523204083445143349658260796401052158770186 ; p = 57896044618658097711785492504343953926634992332820282019728792003956564801911\nIs prime: 1\n"
  },
  {
    "path": "Math/lucas-pratt_primality_proving.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 08 January 2020\n# https://github.com/trizen\n\n# Prove the primality of a number, using the Lucas `U` sequence, recursively factoring N+1.\n\n# Choose P and Q such that D = P^2 - 4*Q is not a square modulo N.\n# Let N+1 = F*R with F > R, where R is odd and the prime factorization of F is known.\n# If there exists a Lucas sequence of discriminant D with U(N+1) == 0 (mod N) and gcd(U((N+1)/q), N) = 1 for each prime q dividing F, then N is prime;\n# If no such sequence exists for a given P and Q, a new P' and Q' with the same D can be computed as P' = P + 2 and Q' = P + Q + 1 (the same D must be used for all the factors q).\n\n# See also:\n#   https://en.wikipedia.org/wiki/Primality_certificate\n#   https://math.stackexchange.com/questions/663341/n1-primality-proving-is-slow\n\nuse 5.020;\nuse strict;\nuse warnings;\nuse experimental qw(signatures);\n\nuse List::Util qw(uniq);\nuse ntheory qw(is_prime is_prob_prime);\nuse Math::Prime::Util::GMP qw(ecm_factor is_strong_pseudoprime);\n\nuse Math::AnyNum qw(\n  :overload prod primorial is_coprime\n  irand min is_square lucasUmod gcd kronecker\n  );\n\nmy $primorial = primorial(10**6);\n\nsub trial_factor ($n) {\n\n    my @f;\n    my $g = gcd($primorial, $n);\n\n    if ($g > 1) {\n        my @primes = ntheory::factor($g);\n        foreach my $p (@primes) {\n            while ($n % $p == 0) {\n                push @f, $p;\n                $n /= $p;\n            }\n        }\n    }\n\n    return ($n, @f);\n}\n\nsub lucas_primality_proving ($n, $lim = 2**64) {\n\n    if ($n <= $lim or $n <= 2) {\n        return is_prime($n);    # fast deterministic test for small n\n    }\n\n    is_prob_prime($n) || return 0;\n\n    if (ref($n) ne 'Math::AnyNum') {\n        $n = Math::AnyNum->new(\"$n\");\n    }\n\n    my $d = $n + 1;\n    my ($B, @f) = trial_factor($d);\n\n    if ($B > 1 and __SUB__->($B, $lim)) {\n        push @f, $B;\n        $B = 1;\n    }\n\n    my $find_PQD = sub {\n\n        my $l = min(10**9, $n - 1);\n\n        for (; ;) {\n            my $P = (irand(1, $l));\n            my $Q = (irand(1, $l) * ((rand(1) < 0.5) ? 1 : -1));\n            my $D = ($P * $P - 4 * $Q);\n\n            next if is_square($D % $n);\n            next if ($P >= $n);\n            next if ($Q >= $n);\n            next if (kronecker($D, $n) != -1);\n\n            return ($P, $Q, $D);\n        }\n    };\n\n    my $primality_proving = sub {\n        my ($P, $Q, $D) = $find_PQD->();\n\n        is_strong_pseudoprime($n, $P + 1)  or return 0;\n        lucasUmod($P, $Q, $n + 1, $n) == 0 or return 0;\n\n        foreach my $p (uniq(@f)) {\n            for (; ;) {\n                $D == ($P * $P - 4 * $Q) or die \"error: $P^2 - 4*$Q != $D\";\n\n                if ($P >= $n or $Q >= $n) {\n                    return __SUB__->();\n                }\n\n                if (is_coprime(lucasUmod($P, $Q, $d / $p, $n), $n)) {\n                    say \"P = $P ; Q = $Q ; p = $p\";\n                    last;\n                }\n\n                ($P, $Q) = ($P + 2, $P + $Q + 1);\n                is_strong_pseudoprime($n, $P) || return 0;\n            }\n        }\n\n        return 1;\n    };\n\n    for (; ;) {\n        my $A = prod(@f);\n\n        if ($A > $B and is_coprime($A, $B)) {\n            say \"\\n:: Proving primality of: $n\";\n            return $primality_proving->();\n        }\n\n        my @ecm_factors = map { Math::AnyNum->new($_) } ecm_factor($B);\n\n        foreach my $p (@ecm_factors) {\n            if (__SUB__->($p, $lim)) {\n                while ($B % $p == 0) {\n                    $B /= $p;\n                    $A *= $p;\n                    push @f, $p;\n                }\n            }\n            if ($A > $B) {\n                say \":: Stopping early with A = $A and B = $B\" if ($B > 1);\n                last;\n            }\n        }\n    }\n}\n\nsay \"Is prime: \", lucas_primality_proving(115792089237316195423570985008687907853269984665640564039457584007913129603823);\n\n__END__\n:: Proving primality of: 160667761273563902473\nP = 637005555 ; Q = -759408520 ; p = 2\nP = 637005555 ; Q = -759408520 ; p = 23\nP = 637005555 ; Q = -759408520 ; p = 137\nP = 637005555 ; Q = -759408520 ; p = 2591\nP = 637005555 ; Q = -759408520 ; p = 77261\nP = 637005555 ; Q = -759408520 ; p = 127356937\n\n:: Proving primality of: 84919921767502888050045396989\nP = 154974193 ; Q = -225311358 ; p = 2\nP = 154974199 ; Q = 239611230 ; p = 3\nP = 154974199 ; Q = 239611230 ; p = 5\nP = 154974199 ; Q = 239611230 ; p = 257\nP = 154974199 ; Q = 239611230 ; p = 2539\nP = 154974199 ; Q = 239611230 ; p = 160667761273563902473\n\n:: Proving primality of: 767990784468614637092681680819989903265059687929\nP = 339178992 ; Q = 3659163746 ; p = 2\nP = 339178992 ; Q = 3659163746 ; p = 3\nP = 339178994 ; Q = 3998342739 ; p = 5\nP = 339178994 ; Q = 3998342739 ; p = 7\nP = 339178994 ; Q = 3998342739 ; p = 56737\nP = 339178994 ; Q = 3998342739 ; p = 190097\nP = 339178994 ; Q = 3998342739 ; p = 3992873\nP = 339178994 ; Q = 3998342739 ; p = 84919921767502888050045396989\n\n:: Proving primality of: 1893865274499603695070553024902095101451637190432913\nP = 699534120 ; Q = -225663681 ; p = 2\nP = 699534120 ; Q = -225663681 ; p = 3\nP = 699534120 ; Q = -225663681 ; p = 137\nP = 699534120 ; Q = -225663681 ; p = 767990784468614637092681680819989903265059687929\n\n:: Proving primality of: 115792089237316195423570985008687907853269984665640564039457584007913129603823\nP = 753451984 ; Q = 491391542 ; p = 2\nP = 753451984 ; Q = 491391542 ; p = 3\nP = 753451984 ; Q = 491391542 ; p = 1669\nP = 753451984 ; Q = 491391542 ; p = 14083\nP = 753451984 ; Q = 491391542 ; p = 1857767\nP = 753451984 ; Q = 491391542 ; p = 29170630189\nP = 753451984 ; Q = 491391542 ; p = 1893865274499603695070553024902095101451637190432913\nIs prime: 1\n"
  },
  {
    "path": "Math/lucas-pratt_prime_records.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 12 May 2019\n# https://github.com/trizen\n\n# Count the number of nodes in the Lucas-Pratt primality tree, rooted at a given prime.\n\n# See also:\n#   https://oeis.org/A037231 -- Primes which set a new record for length of Pratt certificate.\n#   https://oeis.org/A130790 -- Number of nodes in the Lucas-Pratt primality tree rooted at prime(n).\n\nuse 5.020;\nuse warnings;\n\nuse ntheory qw(:all);\nuse Memoize qw(memoize);\nuse experimental qw(signatures);\n\nmemoize('lucas_pratt_primality_tree_count');\n\nsub lucas_pratt_primality_tree_count ($p, $r = -1) {\n\n    return 0 if ($p <= 1);\n    return 1 if ($p == 2);\n\n    vecsum(map { __SUB__->($_->[0], $r) } factor_exp($p + $r));\n}\n\nsub lucas_pratt_prime_records ($r = -1, $upto = 1e6) {\n\n    my $max = 0;\n    my @primes;\n\n    forprimes {\n        my $t = lucas_pratt_primality_tree_count($_, $r);\n        if ($t > $max) {\n            $max = $t;\n            push @primes, $_;\n        }\n    } $upto;\n\n    return @primes;\n}\n\nsay \"p-1: \", join(', ', lucas_pratt_prime_records(-1, 1e6));     # A037231\nsay \"p+1: \", join(', ', lucas_pratt_prime_records(+1, 1e6));\n\n__END__\np-1: 2, 7, 23, 43, 139, 283, 659, 1319, 5179, 9227, 23159, 55399, 148439, 366683, 793439, 1953839, 4875119, 9750239\np+1: 2, 5, 19, 29, 73, 173, 569, 1109, 2917, 5189, 10729, 21169, 42337, 84673, 254021, 508037, 1287457, 3787969, 7575937\n"
  },
  {
    "path": "Math/lucas_factorization_method.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 13 October 2018\n# https://github.com/trizen\n\n# A new integer factorization method, using the Lucas U and V sequences.\n\n# Inspired by the BPSW primality test.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Lucas_sequence\n#   https://en.wikipedia.org/wiki/Lucas_pseudoprime\n#   https://en.wikipedia.org/wiki/Baillie%E2%80%93PSW_primality_test\n\nuse 5.020;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Math::AnyNum qw(:overload bit_scan1 is_power kronecker gcd prod);\nuse Math::Prime::Util::GMP qw(lucas_sequence consecutive_integer_lcm random_nbit_prime);\n\nsub lucas_factorization ($n, $B) {\n\n    return 1 if $n <= 2;\n    return 1 if is_power($n);\n\n    my ($P, $Q) = (1, 0);\n\n    for (my $k = 2 ; ; ++$k) {\n        my $D = (-1)**$k * (2 * $k + 1);\n\n        if (kronecker($D, $n) == -1) {\n            $Q = (1 - $D) / 4;\n            last;\n        }\n    }\n\n    my $d = consecutive_integer_lcm($B);\n    my ($U, $V) = lucas_sequence($n, $P, $Q, $d);\n\n    foreach my $f (sub { gcd($U, $n) }, sub { gcd($V - 2, $n) }) {\n        my $g = $f->();\n        return $g if ($g > 1 and $g < $n);\n    }\n\n    return 1;\n}\n\nsay lucas_factorization(257221 * 470783,               700);     #=> 470783           (p+1 is  700-smooth)\nsay lucas_factorization(333732865481 * 1632480277613,  3000);    #=> 333732865481     (p-1 is 3000-smooth)\nsay lucas_factorization(1124075136413 * 3556516507813, 4000);    #=> 1124075136413    (p+1 is 4000-smooth)\nsay lucas_factorization(6555457852399 * 7864885571993, 700);     #=> 6555457852399    (p-1 is  700-smooth)\nsay lucas_factorization(7553377229 * 588103349,        800);     #=> 7553377229       (p+1 is  800-smooth)\n\n# Example of a larger number that can be factorized fast with this method\nsay lucas_factorization(203544696384073367670016326770637347800169508950125910682353, 19);      #=> 5741461760879844361\n\nsay \"\\n=> More tests:\";\n\nforeach my $k (10 .. 50) {\n\n    my $n = prod(map { random_nbit_prime($k) } 1 .. 2);\n    my $p = lucas_factorization($n, 2 * $n->ilog2**2);\n\n    if ($p > 1 and $p < $n) {\n        say \"$n = $p * \", $n / $p;\n    }\n}\n\n__END__\n36815861 = 6199 * 5939\n748527379 = 31151 * 24029\n2205610861 = 46279 * 47659\n6464972083 = 72623 * 89021\n42908134667 = 165037 * 259991\n144064607993 = 324589 * 443837\n14055375555899 = 3773629 * 3724631\n34326163013579 = 4942513 * 6945083\n635676232543327 = 28513789 * 22293643\n4228743692662373 = 64463821 * 65598713\n44525895097265171 = 211263823 * 210759677\n88671631232856109 = 269999071 * 328414579\n8445394419907066249 = 3185955247 * 2650820167\n508484280918603770621 = 17377315313 * 29261383117\n12301305131668154065127 = 91341582047 * 134673659641\n8834277945256453860289739 = 2536339835969 * 3483081336331\n"
  },
  {
    "path": "Math/lucas_factorization_method_generalized.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 18 May 2019\n# https://github.com/trizen\n\n# A new integer factorization method, using the modular Lucas U sequence.\n\n# It uses the smallest divisor `d` of `p - kronecker(P*P - 4*Q, n)`, such that `U_d(P,Q) = 0 (mod p)`.\n\n# By selecting a small bound B, we compute `k = lcm(1..B)`, hoping that `k` is a\n# multiple of `d`, then `gcd(U_k(P,Q) (mod n), n)` in a non-trivial factor of `n`.\n\n# This method is similar in flavor to Pollard's p-1 and Williams's p+1 methods.\n\nuse 5.020;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Math::AnyNum qw(:overload irand gcd prod);\nuse Math::Prime::Util::GMP qw(lucas_sequence logint consecutive_integer_lcm random_nbit_prime);\n\nsub lucas_factorization ($n, $B = logint($n, 2)**2, $a = 1, $b = 10) {\n\n    my $L = consecutive_integer_lcm($B);\n\n    foreach my $P ($a .. $b) {    # P > 0, P < n\n\n        my $Q = irand(-$n, $n - 1);    # Q < n\n        my $D = ($P * $P - 4 * $Q);    # D != 0\n\n        $D || next;\n\n        my $F = eval { (lucas_sequence($n, $P, $Q, $L))[0] } // next;\n        my $g = gcd($F, $n);\n\n        if ($g > 1 and $g < $n) {\n            return $g;\n        }\n    }\n\n    return 1;\n}\n\nsay lucas_factorization(257221 * 470783,               700);     #=> 470783           (p+1 is  700-smooth)\nsay lucas_factorization(333732865481 * 1632480277613,  3000);    #=> 333732865481     (p-1 is 3000-smooth)\nsay lucas_factorization(1124075136413 * 3556516507813, 4000);    #=> 1124075136413    (p+1 is 4000-smooth)\nsay lucas_factorization(6555457852399 * 7864885571993, 700);     #=> 6555457852399    (p-1 is  700-smooth)\nsay lucas_factorization(7553377229 * 588103349,        800);     #=> 7553377229       (p+1 is  800-smooth)\n\nsay \"\\n=> More factorizations:\";\n\nforeach my $k (10 .. 50) {\n\n    my $n = prod(map { random_nbit_prime($k) } 1 .. 2);\n    my $B = int(log($n) * exp(sqrt(log($n) * log(log($n))) / 2));\n    my $p = lucas_factorization($n, $B);\n\n    if ($p > 1) {\n        printf(\"%s = %s * %s\\n\", $n, $p, $n / $p);\n    }\n}\n\n__END__\n544553 = 631 * 863\n1676989 = 1301 * 1289\n40928003 = 7159 * 5717\n152309891 = 14557 * 10463\n2300268811 = 64627 * 35593\n11952132373 = 108079 * 110587\n88750630231 = 289253 * 306827\n405912740881 = 560089 * 724729\n2327770162243 = 1690309 * 1377127\n12499479778633 = 4032971 * 3099323\n52190728874299 = 6665017 * 7830547\n169450380817337 = 14835001 * 11422337\n413120763604271 = 17965499 * 22995229\n1991077071146719 = 36803257 * 54100567\n7717232903949787 = 92283913 * 83624899\n36847896737907319 = 181428361 * 203098879\n638608157008243187 = 698497087 * 914260301\n3416003128355302301 = 1773283703 * 1926371467\n8189756908298548657 = 3749794309 * 2184054973\n38364912094936082309 = 5629836997 * 6814568897\n114226553742226158113 = 10915936417 * 10464201089\n670007250188746144573 = 30739321757 * 21796422689\n7304335218402627970339 = 84180973361 * 86769431699\n157099299692502309409753 = 432342208787 * 363367944419\n2303492941061419264300001 = 1191794882419 * 1932793113179\n14246977176399484087089437 = 4078455141589 * 3493228853033\n54462337363308569263306589 = 7154666227601 * 7612142290189\n187314575021720258442926711 = 11541166852097 * 16230124511863\n2109644814216084799800489451 = 49099874983879 * 42966398894269\n10333250426104069265111817281 = 97051714715701 * 106471590495581\n42849869010641243828199370319 = 173690504530247 * 246702426977977\n"
  },
  {
    "path": "Math/lucas_pseudoprimes_generation.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 07 October 2018\n# Edit: 19 August 2020\n# https://github.com/trizen\n\n# A new algorithm for generating super-Lucas pseudoprimes.\n\n# See also:\n#   https://oeis.org/A217120 -- Lucas pseudoprimes\n#   https://oeis.org/A217255 -- Strong Lucas pseudoprimes\n#   https://oeis.org/A177745 -- Semiprimes n such that n divides Fibonacci(n+1).\n#   https://oeis.org/A212423 -- Frobenius pseudoprimes == 2,3 (mod 5) with respect to Fibonacci polynomial x^2 - x - 1.\n\n# See also:\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse ntheory qw(:all);\nuse Math::AnyNum qw(prod);\n\nsub lucas_pseudoprimes ($limit, $callback, $P = 1, $Q = -1) {\n\n    my %table;\n    my $D = $P*$P - 4*$Q;\n\n    forprimes {\n        my $p = $_;\n        foreach my $d (divisors($p - kronecker($D, $p))) {\n            if ((lucas_sequence($p, $P, $Q, $d))[0] == 0) {\n                push @{$table{$d}}, $p;\n            }\n        }\n    } 3, $limit;\n\n    foreach my $arr (values %table) {\n\n        my $l = $#{$arr} + 1;\n\n        foreach my $k (2 .. $l) {\n            forcomb {\n                my $n = prod(@{$arr}[@_]);\n                $callback->($n, @{$arr}[@_]);\n            } $l, $k;\n        }\n    }\n}\n\nsub is_weak_lucas_pseudoprime ($n, $P = 1, $Q = -1) {\n\n    my $D = ($P*$P - 4*$Q);\n    my $k = kronecker($D, $n);\n\n    (lucas_sequence($n, $P, $Q, $n - $k))[0] == 0;\n}\n\nmy @pseudoprimes;\n\nlucas_pseudoprimes(\n    10_000,\n    sub ($n, @f) {\n\n        is_weak_lucas_pseudoprime($n, 1, -1) or die \"error: $n\";\n\n        push @pseudoprimes, $n;\n\n        if (kronecker(5, $n) == -1 and powmod(2, $n-1, $n) == 1) {\n            die \"Found a BPSW counter-example: $n = prod(@f)\";\n        }\n    }\n);\n\n@pseudoprimes = sort { $a <=> $b } @pseudoprimes;\n\nsay join(', ', @pseudoprimes);\n\n__END__\n323, 377, 1891, 3827, 4181, 4181, 5777, 5777, 8149, 10877, 10877, 11663, 13201, 15251, 17711, 18407, 19043, 23407, 25877, 27323, 34943, 39203, 40501, 51841, 51983, 53663, 60377, 64079, 64681, 67861, 68251, 75077, 75077, 78409, 86063, 88601, 88831, 88831, 90061, 90061, 94667, 96049, 97921, 97921, 100127, 113573, 113573, 115231, 118441, 121103, 121393, 145351, 146611, 153781, 161027, 162133, 162133, 182513, 191351, 195227, 197209, 200147, 218791, 218791, 219781, 231703, 250277, 250277, 254321, 272611, 294527, 302101, 302101, 303101, 303101, 306287, 330929, 330929, 330929, 345913, 381923, 429263, 430127, 433621, 438751, 453151, 453151, 454607, 456301, 500207, 507527, 520801, 520801, 530611, 548627, 556421, 569087, 572839, 600767, 607561, 629911, 635627, 636641, 636641, 636707, 638189, 642001, 685583, 697883, 721801, 722261, 736163, 741751, 753251, 753377, 775207, 828827, 851927, 853469, 873181, 948433, 954271, 983903, 999941, 999941, 1010651, 1026241, 1033997, 1033997, 1056437, 1056437, 1061341, 1081649, 1081649, 1084201, 1084201, 1084201, 1106327, 1106561, 1174889, 1197377, 1203401, 1203401, 1207361, 1256293, 1256293, 1283311, 1300207, 1314631, 1346269, 1346269, 1346269, 1346269, 1363861, 1388903, 1392169, 1392169, 1418821, 1457777, 1589531, 1626041, 1626041, 1633283, 1633283, 1657847, 1690501, 1697183, 1724213, 1735841, 1735841, 1803601, 1803601, 1950497, 1963501, 1967363, 1970299, 1970299, 2011969, 2039183, 2055377, 2071523, 2122223, 2137277, 2140921, 2140921, 2159389, 2187841, 2187841, 2214143, 2221811, 2253751, 2263127, 2290709, 2362081, 2435423, 2465101, 2465101, 2530007, 2585663, 2586229, 2586229, 2662277, 2662277, 2741311, 2757241, 2757241, 2782223, 2850077, 2872321, 2872321, 2883203, 3140047, 3166057, 3175883, 3175883, 3188011, 3196943, 3277231, 3281749, 3289301, 3338221, 3399527, 3452147, 3459761, 3470921, 3470921, 3526883, 3568661, 3604201, 3645991, 3663871, 3685207, 3768451, 3774377, 3774377, 3850907, 3939167, 3942271, 3992003, 3996991, 4023823, 4109363, 4112783, 4119301, 4119301, 4187341, 4187341, 4226777, 4226777, 4229551, 4359743, 4395467, 4403027, 4403027, 4415251, 4643627, 4672403, 4686391, 4713361, 4713361, 4766327, 4828277, 4828277, 4868641, 4868641, 4870847, 5008643, 5008643, 5016527, 5102959, 5143823, 5208377, 5208377, 5308181, 5328181, 5447881, 5447881, 5536127, 5652191, 5702887, 5734013, 5737577, 5942627, 5998463, 6011777, 6192721, 6192721, 6245147, 6359021, 6359021, 6368689, 6368689, 6374111, 6380207, 6469789, 6471931, 6494801, 6494801, 6494801, 6544561, 6544561, 6571601, 6580549, 6580549, 6671611, 6735007, 6755251, 6759751, 6884131, 6976201, 6986251, 6989569, 7064963, 7067171, 7174081, 7192007, 7225343, 7225343, 7353917, 7353917, 7369601, 7371079, 7398151, 7405201, 7405201, 7451153, 7473407, 7473407, 7493953, 7738363, 7879681, 7879681, 7950077, 7961801, 7961801, 8086231, 8259761, 8259761, 8390933, 8418827, 8502551, 8518127, 8655511, 8668607, 8834641, 8935877, 9031651, 9080191, 9191327, 9351647, 9353761, 9401893, 9401893, 9433883, 9476741, 9476741, 9493579, 9713027, 9793313, 9793313, 9808651, 9811891, 9811891, 9863461, 9863461, 9863461, 9863461, 9922337, 9922337, 10036223, 10339877, 10386241, 10386241, 10403641, 10403641, 10403641, 10403641, 10505701, 10604431, 10614563, 10679131, 10837601, 10837601, 10837601, 11205277, 11388007, 11460077, 11826383, 12007001, 12027023, 12040447, 12049409, 12049409, 12119101, 12119101, 12387799, 12446783, 12537527, 12572983, 12659363, 12958081, 12958081, 12958081, 12975691, 13012651, 13079221, 13158713, 13186637, 13277423, 13295281, 13404751, 13455077, 13455077, 13464467, 13870001, 14197823, 14575091, 14792971, 14892541, 14892541, 14892541, 15309737, 15350723, 15371201, 15576571, 15786647, 15811613, 16060277, 16173827, 16253551, 16403407, 16485493, 16485493, 16724927, 17040383, 17068127, 17288963, 17551883, 17791523, 18673201, 18673201, 18673201, 18673201, 18736381, 18818243, 18888379, 18888379, 19752767, 20018627, 20234341, 20234341, 20261251, 20261251, 20410207, 20412323, 20551301, 20551301, 20621567, 20623969, 20684303, 20754049, 20754049, 21215801, 21511043, 21574279, 21692189, 21692189, 21711583, 21783961, 21843007, 21988961, 22187791, 22361327, 22591301, 22591301, 22591301, 22634569, 22660007, 22669501, 22669501, 22669501, 22924943, 22994371, 22994371, 23307377, 23307377, 23561399, 23581277, 24151381, 24151381, 24157817, 24157817, 24493061, 24493061, 24550241, 24550241, 24681023, 24781423, 24930881, 24930881, 24974777, 24974777, 25183621, 25183621, 25532501, 25532501, 25707841, 25957231, 26118377, 26992877, 27012001, 27012001, 27012001, 27012001, 27085451, 28785077, 28985207, 29242127, 29354723, 29395277, 29395277, 30008483, 31504141, 32012963, 32060027, 32683201, 32683201, 32815361, 32817151, 33385283, 33796531, 33999491, 33999491, 34175777, 34175777, 34433423, 35798491, 35798491, 36307981, 36342653, 37123421, 37510019, 38415203, 38850173, 39088169, 39139127, 39850127, 40208027, 40747877, 40928627, 42149971, 42389027, 42399451, 42702661, 42702661, 43687877, 44166407, 44166407, 45768251, 46094401, 46112921, 46112921, 46114921, 46114921, 46114921, 46114921, 46344377, 46621583, 46672291, 46777807, 47253781, 47728501, 47728501, 48274703, 49019851, 49476377, 49476377, 49863661, 50808383, 50823151, 51803761, 51803761, 51876301, 53406863, 53655551, 55621763, 55681841, 55681841, 55830251, 56070143, 56972303, 57113717, 60186563, 62062883, 65415743, 70358543, 72897443, 73925603, 74442383, 75821503, 78110243, 78478943, 79624621, 83983073, 85423337, 89075843, 93663683, 93663683, 95413823, 97180163, 118901521, 121543501, 142030331, 224056801, 241924073, 246858841, 247679023, 388148903, 425399633, 429718411, 485989067, 732773791, 841980289, 957600541, 1312939321, 1706314037, 1932942527, 1952566309, 2166124801, 2166249691, 2244734413, 3173584391, 3383791321, 3383791321, 3406661927, 3585571907, 3807749821, 3807749821, 3938826767, 4250132963, 4293281521, 4369513223, 4598585921, 4610083201, 5073193501, 5374978561, 5410184641, 5802147391, 6317014703, 6390421291, 6486191209, 6666202787, 7917170801, 7917170801, 8631989203, 8645365081, 9340061821, 9506984911, 10193270401, 10490001721, 10521133201, 10908573077, 11384387281, 11851534697, 11851534697, 12182626763, 12525647327, 14678225269, 15216199501, 19770082847, 19941055289, 20286012751, 21380110489, 21936153271, 25933744367, 30550875623, 32376761983, 32855188591, 34933139161, 35646833933, 35646833933, 41898691223, 44912519441, 47075139721, 48306406891, 48568811171, 51068212561, 51489442351, 52396612381, 52396612381, 60804014251, 70504918721, 70504918721, 71432012629, 73817444191, 80952788071, 84654526967, 192813486181, 309385004989, 314101265081, 384655562873, 845776459637, 4211881766333, 4254641987311, 4382720043971, 45663814702501, 55216945762217, 79511946282173, 295569290441221, 838164471500267\n"
  },
  {
    "path": "Math/lucas_pseudoprimes_generation_erdos_method.pl",
    "content": "#!/usr/bin/perl\n\n# Erdos construction method for Lucas D-pseudoprimes, for discriminant D = P^2-4Q:\n#   1. Choose an even integer L with many divisors.\n#   2. Let P be the set of primes p such that p-kronecker(D,p) divides L and p does not divide L.\n#   3. Find a subset S of P such that n = prod(S) satisfies U_n(P,Q) == 0 (mod n) and kronecker(D,n) == -1.\n\n# Alternatively:\n#   3. Find a subset S of P such that n = prod(P) / prod(S) satisfies U_n(P,Q) == 0 (mod n) and kronecker(D,n) == -1.\n\nuse 5.020;\nuse warnings;\n\nuse ntheory qw(:all);\nuse List::Util qw(uniq);\nuse experimental qw(signatures);\n\nsub lambda_primes ($L, $D) {\n\n    # Primes p such that `p - kronecker(D,p)` divides L and p does not divide L.\n\n    my @divisors = divisors($L);\n\n    my @A = grep { ($_ > 2) and is_prime($_) and ($L % $_ != 0) and kronecker($D, $_) == -1 } map { $_ - 1 } @divisors;\n    my @B = grep { ($_ > 2) and is_prime($_) and ($L % $_ != 0) and kronecker($D, $_) == +1 } map { $_ + 1 } @divisors;\n\n    sort { $a <=> $b } uniq(@A, @B);\n}\n\nsub lucas_pseudoprimes ($L, $P = 1, $Q = -1) {\n\n    my $D = ($P * $P - 4 * $Q);\n    my @P = lambda_primes($L, $D);\n\n    foreach my $k (2 .. @P) {\n        forcomb {\n\n            my $n = vecprod(@P[@_]);\n            my $k = kronecker($D, $n);\n\n            if ((lucas_sequence($n, $P, $Q, $n - $k))[0] == 0) {\n                say $n;\n            }\n        } scalar(@P), $k;\n    }\n}\n\nlucas_pseudoprimes(720, 1, -1);\n\n__END__\n323\n1891\n6601\n13981\n342271\n1590841\n852841\n3348961\n9937081\n16778881\n72881641\n10756801\n154364221\n205534681\n609865201\n807099601\n1438048801\n7692170761\n921921121\n32252538601\n222182990161\n2051541911881\n2217716806743361\n"
  },
  {
    "path": "Math/lucas_sequences_U_V.pl",
    "content": "#!/usr/bin/perl\n\n# Algorithm due to Aleksey Koval for computing the Lucas U and V sequences.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Lucas_sequence\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse Math::AnyNum qw(:overload digits);\n\nsub lucasUV ($n, $P, $Q) {\n\n    my ($V1, $V2) = (2, $P);\n    my ($Q1, $Q2) = (1, 1);\n\n    my @bits = digits($n, 2);\n\n    while (@bits) {\n\n        $Q1 *= $Q2;\n\n        if (pop @bits) {\n            $Q2 = ($Q1 * $Q);\n            $V1 = ($V2 * $V1 - $P * $Q1);\n            $V2 = ($V2 * $V2 - 2 * $Q2);\n        }\n        else {\n            $Q2 = $Q1;\n            $V2 = ($V2 * $V1 - $P * $Q1);\n            $V1 = ($V1 * $V1 - 2 * $Q2);\n        }\n    }\n\n    my $Uk = (2 * $V2 - $P * $V1) / ($P * $P - 4 * $Q);\n\n    return ($Uk, $V1);\n}\n\nforeach my $n (1 .. 20) {\n    say \"[\", join(', ', lucasUV($n, 1, -1)), \"]\";\n}\n\n__END__\n[1, 1]\n[1, 3]\n[2, 4]\n[3, 7]\n[5, 11]\n[8, 18]\n[13, 29]\n[21, 47]\n[34, 76]\n[55, 123]\n[89, 199]\n[144, 322]\n[233, 521]\n[377, 843]\n[610, 1364]\n[987, 2207]\n[1597, 3571]\n[2584, 5778]\n[4181, 9349]\n[6765, 15127]\n"
  },
  {
    "path": "Math/lucas_sequences_U_V_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Algorithm due to Aleksey Koval for computing the Lucas U and V sequences.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Lucas_sequence\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse Math::GMPz;\n\nsub lucasUV ($n, $P, $Q) {\n\n    $n = Math::GMPz->new(\"$n\");\n    $P = Math::GMPz->new(\"$P\");\n    $Q = Math::GMPz->new(\"$Q\");\n\n    my ($V1, $V2) = (Math::GMPz::Rmpz_init_set_ui(2), Math::GMPz::Rmpz_init_set($P));\n    my ($Q1, $Q2) = (Math::GMPz::Rmpz_init_set_ui(1), Math::GMPz::Rmpz_init_set_ui(1));\n\n    my $t = Math::GMPz::Rmpz_init();\n    my $v = Math::GMPz::Rmpz_init();\n\n    foreach my $bit (split(//, Math::GMPz::Rmpz_get_str($n, 2))) {\n\n        Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);\n\n        if ($bit) {\n            Math::GMPz::Rmpz_mul($Q2, $Q1, $Q);\n            Math::GMPz::Rmpz_mul($V1, $V1, $V2);\n            Math::GMPz::Rmpz_mul($t,  $P,  $Q1);\n            Math::GMPz::Rmpz_mul($V2, $V2, $V2);\n            Math::GMPz::Rmpz_sub($V1, $V1, $t);\n            Math::GMPz::Rmpz_submul_ui($V2, $Q2, 2);\n        }\n        else {\n            Math::GMPz::Rmpz_set($Q2, $Q1);\n            Math::GMPz::Rmpz_mul($V2, $V2, $V1);\n            Math::GMPz::Rmpz_mul($t,  $P,  $Q1);\n            Math::GMPz::Rmpz_mul($V1, $V1, $V1);\n            Math::GMPz::Rmpz_sub($V2, $V2, $t);\n            Math::GMPz::Rmpz_submul_ui($V1, $Q2, 2);\n        }\n    }\n\n    Math::GMPz::Rmpz_mul_2exp($t, $V2, 1);\n    Math::GMPz::Rmpz_submul($t, $P, $V1);\n    Math::GMPz::Rmpz_mul($v, $P, $P);\n    Math::GMPz::Rmpz_submul_ui($v, $Q, 4);\n    Math::GMPz::Rmpz_divexact($t, $t, $v);\n\n    return ($t, $V1);\n}\n\nforeach my $n (1 .. 20) {\n    say \"[\", join(', ', lucasUV($n, 1, -1)), \"]\";\n}\n\n__END__\n[1, 1]\n[1, 3]\n[2, 4]\n[3, 7]\n[5, 11]\n[8, 18]\n[13, 29]\n[21, 47]\n[34, 76]\n[55, 123]\n[89, 199]\n[144, 322]\n[233, 521]\n[377, 843]\n[610, 1364]\n[987, 2207]\n[1597, 3571]\n[2584, 5778]\n[4181, 9349]\n[6765, 15127]\n"
  },
  {
    "path": "Math/lucas_theorem.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date 04 September 2020\n# https://github.com/trizen\n\n# Simple implementation of Lucas's theorem, for computing binomial(n,k) mod p, for some prime p.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Lucas%27s_theorem\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(:all);\n\nsub factorial_valuation ($n, $p) {\n    ($n - vecsum(todigits($n, $p))) / ($p - 1);\n}\n\nsub modular_binomial ($n, $k, $m) {    # fast for small n\n\n    my $j    = $n - $k;\n    my $prod = 1;\n\n    forprimes {\n        my $p = factorial_valuation($n, $_);\n\n        if ($_ <= $k) {\n            $p -= factorial_valuation($k, $_);\n        }\n\n        if ($_ <= $j) {\n            $p -= factorial_valuation($j, $_);\n        }\n\n        if ($p > 0) {\n            $prod *= ($p == 1) ? ($_ % $m) : powmod($_, $p, $m);\n            $prod %= $m;\n        }\n    } $n;\n\n    return $prod;\n}\n\nsub lucas_theorem ($n, $k, $p) {\n\n    if ($n < $k) {\n        return 0;\n    }\n\n    my $res = 1;\n\n    while ($k > 0) {\n        my ($Nr, $Kr) = ($n % $p, $k % $p);\n\n        if ($Nr < $Kr) {\n            return 0;\n        }\n\n        ($n, $k) = (divint($n, $p), divint($k, $p));\n        $res = mulmod($res, modular_binomial($Nr, $Kr, $p), $p);\n    }\n\n    return $res;\n}\n\nsub lucas_theorem_alt ($n, $k, $p) {    # alternative implementation\n\n    if ($n < $k) {\n        return 0;\n    }\n\n    my @Nd = reverse todigits($n, $p);\n    my @Kd = reverse todigits($k, $p);\n\n    my $res = 1;\n\n    foreach my $i (0 .. $#Kd) {\n\n        my $Nr = $Nd[$i];\n        my $Kr = $Kd[$i];\n\n        if ($Nr < $Kr) {\n            return 0;\n        }\n\n        $res = mulmod($res, modular_binomial($Nr, $Kr, $p), $p);\n    }\n\n    return $res;\n}\n\nsay lucas_theorem(1e10,           1e5,           1009);    #=> 559\nsay lucas_theorem(powint(10, 18), powint(10, 9), 2957);    #=> 2049\n\nsay '';\n\nsay lucas_theorem_alt(1e10,           1e5,           1009);    #=> 559\nsay lucas_theorem_alt(powint(10, 18), powint(10, 9), 2957);    #=> 2049\n"
  },
  {
    "path": "Math/magic_3-gon_ring.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 08 August 2016\n# Website: https://github.com/trizen\n\n# Solve a magic 3-gon ring.\n# See: https://projecteuler.net/problem=68\n\nuse 5.014;\nuse ntheory qw(forperm);\n\nmy @nums = (1 .. 6);\n\nforperm {\n    my @d = @nums[@_];\n    my $n = $d[0] + $d[1] + $d[2];\n\n    if (    $d[0] < $d[3]\n        and $d[0] < $d[5]\n        and $n == $d[3] + $d[2] + $d[4]\n        and $n == $d[5] + $d[4] + $d[1]) {\n        say \"($d[0] $d[1] $d[2] | $d[3] $d[2] $d[4] | $d[5] $d[4] $d[1]) = $n\";\n    }\n} scalar(@nums);\n"
  },
  {
    "path": "Math/magic_5-gon_ring.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 08 August 2016\n# Website: https://github.com/trizen\n\n# Solve a magic 5-gon ring.\n# See: https://projecteuler.net/problem=68\n\nuse 5.014;\nuse ntheory qw(forperm);\n\nmy $max  = '';\nmy @nums = (1 .. 10);\n\nforperm {\n    my @d = @nums[@_];\n\n    my $i = $d[0] + $d[1] + $d[2];\n    my $j = $d[3] + $d[2] + $d[4];\n    my $k = $d[5] + $d[4] + $d[6];\n    my $l = $d[7] + $d[6] + $d[8];\n    my $m = $d[9] + $d[8] + $d[1];\n\n    if (    $d[0] < $d[3]\n        and $d[0] < $d[5]\n        and $d[0] < $d[7]\n        and $d[0] < $d[9]\n        and $i == $j\n        and $i == $k\n        and $i == $l\n        and $i == $m\n    ) {\n        printf(\n            \"(%2d %2d %2d | %2d %2d %2d | %2d %2d %2d | %2d %2d %2d | %2d %2d %2d) = %2d\\n\",\n\n            $d[0], $d[1], $d[2],\n            $d[3], $d[2], $d[4],\n            $d[5], $d[4], $d[6],\n            $d[7], $d[6], $d[8],\n            $d[9], $d[8], $d[1],\n\n            $i\n        );\n    }\n} scalar(@nums);\n"
  },
  {
    "path": "Math/map_num.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# License: GPLv3\n# Date: 08th October 2013\n# https://trizenx.blogspot.com\n\n# Map an amount of numbers in a given interval\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub map_num {\n    my ($amount, $from, $to) = @_;\n\n    my $diff = $to - $from;\n    my $step = $diff / $amount;\n\n    return if $step == 0;\n\n    my @nums;\n    for (my $i = $from ; $i <= $to ; $i += $step) {\n        push @nums, $i;\n    }\n\n    return @nums;\n}\n\nsay join \"\\n\", map_num(10, 4, 5);\n"
  },
  {
    "path": "Math/matrix_determinant_bareiss.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 20 November 2016\n# https://github.com/trizen\n\n# The Bareiss algorithm for computing the determinant of a (square) matrix.\n\n# Algorithm from:\n#   https://apidock.com/ruby/v1_9_3_125/Matrix/determinant_bareiss\n\n# See also:\n#   https://en.wikipedia.org/wiki/Bareiss_algorithm\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse List::Util qw(first);\n\nsub det {\n    my ($m) = @_;\n\n    my @m = map { [@$_] } @$m;\n\n    my $sign  = +1;\n    my $pivot = 1;\n    my $end   = $#m;\n\n    foreach my $k (0 .. $end) {\n        my @r = ($k + 1 .. $end);\n\n        my $prev_pivot = $pivot;\n        $pivot = $m[$k][$k];\n\n        if ($pivot == 0) {\n            my $i = (first { $m[$_][$k] } @r) // return 0;\n            @m[$i, $k] = @m[$k, $i];\n            $pivot = $m[$k][$k];\n            $sign  = -$sign;\n        }\n\n        foreach my $i (@r) {\n            foreach my $j (@r) {\n                (($m[$i][$j] *= $pivot) -= $m[$i][$k] * $m[$k][$j]) /= $prev_pivot;\n            }\n        }\n    }\n\n    $sign * $pivot;\n}\n\nmy $matrix = [\n    [2, -1,  5,  1],\n    [3,  2,  2, -6],\n    [1,  3,  3, -1],\n    [5, -2, -3,  3],\n];\n\nsay det($matrix);       #=> 684\n"
  },
  {
    "path": "Math/matrix_path_2-ways_best.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 08 August 2016\n# Website: https://github.com/trizen\n\n# Find the best-minimum path-sum from the top-left of a matrix, to the bottom-right.\n# Inspired by: https://projecteuler.net/problem=81\n\n# The path moves only right and down.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse List::Util qw(min);\nuse Memoize qw(memoize);\n\nmemoize('path');\n\nmy @matrix = (\n              [131, 673, 234, 103, 18],\n              [201, 96,  342, 965, 150],\n              [630, 803, 746, 422, 111],\n              [537, 699, 497, 121, 956],\n              [805, 732, 524, 37,  331],\n             );\n\nmy $end = $#matrix;\n\nsub path {\n    my ($i, $j) = @_;\n\n    if ($i < $end and $j < $end) {\n        return $matrix[$i][$j] + min(path($i + 1, $j), path($i, $j + 1));\n    }\n\n    if ($i < $end) {\n        return $matrix[$i][$j] + path($i + 1, $j);\n    }\n\n    if ($j < $end) {\n        return $matrix[$i][$j] + path($i, $j + 1);\n    }\n\n    $matrix[$i][$j];\n}\n\nsay path(0, 0);\n"
  },
  {
    "path": "Math/matrix_path_2-ways_greedy.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 08 August 2016\n# Website: https://github.com/trizen\n\n# Find the greedy-minimum path from each end of a square matrix.\n# Inspired by: https://projecteuler.net/problem=81\n\n# \"Path 1\" is from the top-left of the matrix, to the bottom-right.\n# \"Path 2\" is from the bottom-right of the matrix, to the top-left.\n\n# \"Path 1\" moves only right and down.\n# \"Path 2\" moves only left and up.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nmy @matrix = (\n              [131, 673, 234, 103, 18],\n              [201, 96,  342, 965, 150],\n              [630, 803, 746, 422, 111],\n              [537, 699, 497, 121, 956],\n              [805, 732, 524, 37,  331],\n             );\n\nmy $end = $#matrix;\n\nmy @path_1;\nmy @path_2;\n\n{\n    my $i = 0;\n    my $j = 0;\n\n    push @path_1, $matrix[$i][$j];\n\n    while (1) {\n\n        if (    exists($matrix[$i][$j + 1])\n            and exists($matrix[$i + 1])\n            and $matrix[$i][$j + 1] < $matrix[$i + 1][$j]) {\n            ++$j;\n        }\n        else {\n            ++$i;\n        }\n\n        push @path_1, $matrix[$i][$j];\n\n        if ($i == $end and $j == $end) { last }\n    }\n}\n\n{\n\n    my $i = $end;\n    my $j = $end;\n\n    push @path_2, $matrix[$i][$j];\n\n    while (1) {\n\n        if (    $j - 1 >= 0\n            and $i - 1 >= 0\n            and exists($matrix[$i][$j - 1])\n            and exists($matrix[$i - 1])\n            and $matrix[$i][$j - 1] < $matrix[$i - 1][$j]) {\n            --$j;\n        }\n        else {\n            --$i;\n        }\n\n        push @path_2, $matrix[$i][$j];\n\n        if ($i == 0 and $j == 0) { last }\n    }\n\n}\n\nsay \"Path 1: [@path_1]\";\nsay \"Path 2: [@path_2]\";\n"
  },
  {
    "path": "Math/matrix_path_3-ways_best.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 13 August 2016\n# Website: https://github.com/trizen\n\n# The minimal path sum in the 5 by 5 matrix below, by starting in any cell\n# in the left column and finishing in any cell in the right column, and only\n# moving up, down, and right; the sum is equal to 994.\n\n# This algorithm finds the best possible path.\n# The problem was taken from: https://projecteuler.net/problem=82\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nno warnings 'recursion';\n\nuse List::Util qw(min);\nuse Memoize qw(memoize);\n\nmemoize('path');\n\nmy @matrix = (\n              [131, 673, 234, 103, 18],\n              [201, 96,  342, 965, 150],\n              [630, 803, 746, 422, 111],\n              [537, 699, 497, 121, 956],\n              [805, 732, 524, 37,  331],\n             );\n\nmy $end = $#matrix;\n\nsub path {\n    my ($i, $j, $last) = @_;\n\n    $j >= $end && return $matrix[$i][$j];\n\n    my @paths;\n    if ($i > 0 and $last ne 'down') {\n        push @paths, path($i - 1, $j, 'up');\n    }\n\n    push @paths, path($i, $j + 1, 'ok');\n\n    if ($i < $end and $last ne 'up') {\n        push @paths, path($i + 1, $j, 'down');\n    }\n\n    my $min = 'inf';\n\n    foreach my $sum (@paths) {\n        $min = $sum if $sum < $min;\n    }\n\n    $min + $matrix[$i][$j];\n}\n\nmy @sums;\nforeach my $i (0 .. $end) {\n    push @sums, path($i, 0, 'ok');\n}\n\nsay min(@sums);\n"
  },
  {
    "path": "Math/matrix_path_3-ways_diagonal_best.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 04 August 2017\n# https://github.com/trizen\n\n# Find the lowest-cost possible path in a matrix, by starting\n# in the top-left corner of the matrix and finishing in the\n# bottom-right corner, and only moving up, down, and right.\n\n# Problem closely related to:\n#   https://projecteuler.net/problem=82\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nno warnings 'recursion';\n\nuse List::Util qw(min);\nuse Memoize qw(memoize);\n\nmemoize('path');\n\nmy @matrix = (\n              [131, 673,   4, 103,  18],\n              [ 21,  96, 342, 965, 150],\n              [630, 803, 746, 422, 111],\n              [537, 699, 497, 121,  56],\n              [805, 732, 524,  37, 331],\n             );\n\nmy $end = $#matrix;\n\nsub path {\n    my ($i, $j, $last, @path) = @_;\n\n    if ($i == $end and $j == $end) {\n        return ($matrix[$i][$j], @path, $matrix[$i][$j]);\n    }\n    elsif ($j > $end) {\n        return ('inf', @path);\n    }\n\n    my $item = $matrix[$i][$j];\n\n    my @paths;\n    if ($i > 0 and $last ne 'down') {\n        push @paths, [path($i - 1, $j, 'up', @path, $item)];\n    }\n\n    push @paths, [path($i, $j + 1, 'ok', @path, $item)];\n\n    if ($i < $end and $last ne 'up') {\n        push @paths, [path($i + 1, $j, 'down', @path, $item)];\n    }\n\n    my $min = 'inf';\n\n    foreach my $group (@paths) {\n        my ($sum, @p) = @{$group};\n\n        if ($sum < $min) {\n            $min  = $sum;\n            @path = @p;\n        }\n    }\n\n    ($min + $item, @path);\n}\n\nmy ($sum, @path) = path(0, 0, 'ok');\n\nsay \"Cost: $sum\";       #=> Cost: 1363\nsay \"Path: [@path]\";    #=> Path: [131 21 96 342 4 103 18 150 111 56 331]\n"
  },
  {
    "path": "Math/matrix_path_3-ways_greedy.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 13 August 2016\n# Website: https://github.com/trizen\n\n# The minimal path sum in the 5 by 5 matrix below, by starting in any cell\n# in the left column and finishing in any cell in the right column, and only\n# moving up, down, and right; the sum is equal to 994.\n\n# This is a greedy algorithm.\n# The problem was taken from: https://projecteuler.net/problem=82\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nmy @matrix = (\n              [131, 673, 234, 103, 18],\n              [201, 96,  342, 965, 150],\n              [630, 803, 746, 422, 111],\n              [537, 699, 497, 121, 956],\n              [805, 732, 524, 37,  331],\n             );\n\nmy $end = $#matrix;\nmy $min = 'inf';\n\nforeach my $i (0 .. $#matrix) {\n    my $sum = $matrix[$i][0];\n\n    my $j    = 0;\n    my $last = 'ok';\n\n    while (1) {\n        my @ways;\n\n        if ($i > 0 and $last ne 'down') {\n            push @ways, [-1, 0, $matrix[$i - 1][$j], 'up'];\n        }\n\n        if ($j < $end) {\n            push @ways, [0, 1, $matrix[$i][$j + 1], 'ok'];\n        }\n\n        if ($i < $end and $last ne 'up') {\n            push @ways, [1, 0, $matrix[$i + 1][$j], 'down'];\n        }\n\n        my $m = [0, 0, 'inf', 'ok'];\n\n        foreach my $way (@ways) {\n            $m = $way if $way->[2] < $m->[2];\n        }\n\n        $i   += $m->[0];\n        $j   += $m->[1];\n        $sum += $m->[2];\n        $last = $m->[3];\n\n        last if $j >= $end;\n    }\n\n    $min = $sum if $sum < $min;\n}\n\nsay $min;\n"
  },
  {
    "path": "Math/matrix_path_4-ways_best.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 08 August 2016\n# Website: https://github.com/trizen\n\n# In the 5 by 5 matrix below, the minimal path sum from the top left\n# to the bottom right, by moving left, right, up, and down, is equal to 2297.\n\n# Problem from: https://projecteuler.net/problem=83\n\n# (this algorithm is not scalable for matrices beyond 5x5)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse List::Util qw(min);\n\nmy @matrix = (\n              [131, 673, 234, 103, 18],\n              [201, 96,  342, 965, 150],\n              [630, 803, 746, 422, 111],\n              [537, 699, 497, 121, 956],\n              [805, 732, 524, 37,  331],\n             );\n\nmy %seen;\nmy $end = $#matrix;\n\nsub rec {\n    my ($i, $j, @vecs) = @_;\n\n    @vecs = (\n             grep { not exists $seen{\"@{$_}\"} }\n             map { [$_->[0] + $i, $_->[1] + $j] } @vecs\n            );\n\n    @vecs || return 'inf';\n\n    undef $seen{\"$i $j\"};\n    my $res = $matrix[$i][$j] + min(map { path(@{$_}) } @vecs);\n    delete $seen{\"$i $j\"};\n\n    return $res;\n}\n\nsub path {\n    my ($i, $j) = @_;\n\n    if ($i == 0 and $j == 0) {\n        return rec($i, $j, [1, 0], [0, 1]);\n    }\n\n    if ($i == 0 and $j == $end) {\n        return rec($i, $j, [0, -1], [1, 0]);\n    }\n\n    if ($i == $end and $j == 0) {\n        return rec($i, $j, [-1, 0], [0, 1]);\n    }\n\n    if ($i == 0 and $j > 0 and $j < $end) {\n        return rec($i, $j, [1, 0], [0, 1], [0, -1]);\n    }\n\n    if ($i == $end and $j > 0 and $j < $end) {\n        return rec($i, $j, [-1, 0], [0, -1], [0, 1]);\n    }\n\n    if ($j == 0 and $i > 0 and $i < $end) {\n        return rec($i, $j, [-1, 0], [1, 0], [0, 1]);\n    }\n\n    if ($j == $end and $i > 0 and $i < $end) {\n        return rec($i, $j, [-1, 0], [1, 0], [0, -1]);\n    }\n\n    if ($i > 0 and $j > 0 and $i < $end and $j < $end) {\n        return rec($i, $j, [1, 0], [0, 1], [-1, 0], [0, -1]);\n    }\n\n    $matrix[$i][$j];\n}\n\nsay path(0, 0);\n"
  },
  {
    "path": "Math/matrix_path_4-ways_best_2.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 13 August 2016\n# Website: https://github.com/trizen\n\n# In the 5 by 5 matrix below, the minimal path sum from the top left\n# to the bottom right, by moving left, right, up, and down, is equal to 2297.\n\n# Problem from: https://projecteuler.net/problem=83\n\n# (this algorithm is scalable only up to 7x7 matrices)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Memoize qw(memoize);\n\nmy @matrix = (\n              [131, 673, 234, 103, 18],\n              [201, 96,  342, 965, 150],\n              [630, 803, 746, 422, 111],\n              [537, 699, 497, 121, 956],\n              [805, 732, 524, 37,  331],\n             );\n\nmemoize('path');\nmy $end = $#matrix;\n\nsub path {\n    my ($i, $j, $seen) = @_;\n\n    my @seen = split(' ', $seen);\n\n    my $valid = sub {\n        my %seen;\n        @seen{@seen} = ();\n        not exists $seen{\"$_[0]:$_[1]\"};\n    };\n\n    if ($i >= $end and $j >= $end) {\n        return $matrix[$i][$j];\n    }\n\n    my @points;\n\n    if ($j < $end and $valid->($i, $j + 1)) {\n        push @points, [$i, $j + 1];\n    }\n\n    if ($i > 0 and $valid->($i - 1, $j)) {\n        push @points, [$i - 1, $j];\n    }\n\n    if ($j > 0 and $valid->($i, $j - 1)) {\n        push @points, [$i, $j - 1];\n    }\n\n    if ($i < $end and $valid->($i + 1, $j)) {\n        push @points, [$i + 1, $j];\n    }\n\n    my $min = 'inf';\n    my $snn = join(' ', sort (@seen, map { join(':', @$_) } @points));\n\n    foreach my $point (@points) {\n        my $sum = path(@$point, $snn);\n        $min = $sum if $sum < $min;\n    }\n\n    $min + $matrix[$i][$j];\n}\n\nsay path(0, 0, '');\n"
  },
  {
    "path": "Math/matrix_path_4-ways_best_3.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 14 August 2016\n# Website: https://github.com/trizen\n\n# Problem from: https://projecteuler.net/problem=83\n\n# (this algorithm is scalable up to matrices of size 80x80)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nno warnings 'recursion';\n\nuse List::Util qw(min max);\nuse Term::ANSIColor qw(colored);\n\nmy @matrix = map {\n    [map { int rand 10_000 } 1 .. 15]\n} 1 .. 15;\n\nsub draw {\n    my ($path) = @_;\n\n    print \"\\e[H\\e[J\\e[H\";\n    my @screen = map {\n        [map { sprintf \"%4s\", $_ } @{$_}]\n    } @matrix;\n\n    foreach my $p (@$path) {\n        my ($i, $j) = @$p;\n        $screen[$i][$j] = colored($screen[$i][$j], 'red');\n    }\n\n    foreach my $row (@screen) {\n        say join(' ', @{$row});\n    }\n}\n\nmy %seen;\n\nsub valid {\n    not exists $seen{\"@_\"};\n}\n\nmy %two_way_cache;\nmy $end = $#matrix;\n\nsub two_way_path {\n    my ($i, $j, $k, $l) = @_;\n\n    my $key = \"$i $j $k $l\";\n    if (exists $two_way_cache{$key}) {\n        return $two_way_cache{$key};\n    }\n\n    my @paths;\n\n    if ($i < $k) {\n        push @paths, two_way_path($i + 1, $j, $k, $l);\n    }\n\n    if ($j < $l) {\n        push @paths, two_way_path($i, $j + 1, $k, $l);\n    }\n\n    $two_way_cache{$key} = $matrix[$i][$j] + (min(@paths) || 0);\n}\n\nmy @stack;\nmy $sum = 0;\nmy ($i, $j) = (0, 0);\nmy $limit = two_way_path(0, 0, $end, $end);\nmy $max = max(map { @$_ } @matrix);\n\nmy %min = (sum => 'inf');\n\nwhile (1) {\n    undef $seen{\"$i $j\"};\n    $sum += $matrix[$i][$j];\n\n    my @points;\n\n    if ($i >= $end and $j >= $end) {\n        if ($sum < $min{sum}) {\n            $min{sum}  = $sum;\n            $min{path} = [keys %seen];\n        }\n        @stack ? goto STACK: last;\n    }\n\n    # Skip invalid starting paths\n    if (not($sum <= $limit) or not($sum <= two_way_path(0, 0, $i, $j))) {\n        goto STACK if @stack;\n    }\n\n    # Skip invalid ending paths (this is a HUGE optimization)\n    if (not($sum - $matrix[$i][$j] + two_way_path($i, $j, $end, $end) <= $limit + $max)) {\n        goto STACK if @stack;\n    }\n\n    if ($i > 0 and valid($i - 1, $j)) {\n        push @points, [$i - 1, $j];\n    }\n\n    if ($j > 0 and valid($i, $j - 1)) {\n        push @points, [$i, $j - 1];\n    }\n\n    if ($i < $end and valid($i + 1, $j)) {\n        push @points, [$i + 1, $j];\n    }\n\n    if ($j < $end and valid($i, $j + 1)) {\n        push @points, [$i, $j + 1];\n    }\n\n  STACK: if (!@points) {\n        if (@stack) {\n            my ($s_sum, $s_seen, $s_pos, $s_points) = @{pop @stack};\n            $sum = $s_sum;\n            undef %seen;\n            @seen{@$s_seen} = ();\n            @points = @$s_points;\n            ($i, $j) = @$s_pos;\n        }\n        else {\n            last;\n        }\n    }\n\n    my $min = splice(@points, int(rand(@points)), 1);\n\n    if (@points) {\n\n        my @ok = (\n            grep {\n                my $s = ($sum + $matrix[$_->[0]][$_->[1]]);\n                $s <= $limit\n                  and ($s <= two_way_path(0, 0, $_->[0], $_->[1]))\n                  and ($sum + two_way_path($_->[0], $_->[1], $end, $end) <= $limit + $max)\n              } @points\n        );\n\n        if (@ok) {\n            push @stack, [$sum, [keys %seen], [$i, $j], \\@ok];\n        }\n    }\n\n    ($i, $j) = @$min;\n}\n\nmy @path = map { [split ' '] } @{$min{path}};\ndraw(\\@path);\n\nsay \"\\nMinimum path-sum is: $min{sum}\\n\";\n"
  },
  {
    "path": "Math/matrix_path_4-ways_greedy.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 13 August 2016\n# Website: https://github.com/trizen\n\n# In the 5 by 5 matrix below, the minimal path sum from the top left\n# to the bottom right, by moving left, right, up, and down, is equal to 2297.\n\n# Problem from: https://projecteuler.net/problem=83\n\n# (this algorithm works only with matrices that are guaranteed to have a greedy path available)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse List::UtilsBy qw(min_by);\n\nmy @matrix = (\n              [131, 673, 234, 103, 18],\n              [201, 96,  342, 965, 150],\n              [630, 803, 746, 422, 111],\n              [537, 699, 497, 121, 956],\n              [805, 732, 524, 37,  331],\n             );\n\nmy @seen = \"0 0\";\n\nsub valid {\n    my %seen;\n    @seen{@seen} = ();\n    not exists $seen{\"@_\"};\n}\n\nmy $sum = 0;\nmy $end = $#matrix;\n\nmy ($i, $j) = (0, 0);\n\nwhile (1) {\n    say $matrix[$i][$j];\n    $sum += $matrix[$i][$j];\n\n    if ($i >= $end and $j >= $end) {\n        last;\n    }\n\n    my @points;\n\n    if ($i > 0 and valid($i - 1, $j)) {\n        push @points, [$i - 1, $j];\n    }\n\n    if ($j > 0 and valid($i, $j - 1)) {\n        push @points, [$i, $j - 1];\n    }\n\n    if ($i < $end and valid($i + 1, $j)) {\n        push @points, [$i + 1, $j];\n    }\n\n    if ($j < $end and valid($i, $j + 1)) {\n        push @points, [$i, $j + 1];\n    }\n\n    @points || do {\n        say \"Stuck at value: $sum\";\n        last;\n    };\n\n    my $min = min_by { $matrix[$_->[0]][$_->[1]] } @points;\n\n    ($i, $j) = @{$min};\n    push @seen, \"$i $j\";\n}\n\nsay \"Minimum path-sum is: $sum\";\n"
  },
  {
    "path": "Math/maximum_product_of_parts_bisection.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 18 October 2017\n# https://github.com/trizen\n\n# Finds the value of `k` such that:\n#   (x/(k-1))^(k-1) < (x/k)^k > (x/(k+1))^(k+1)\n\n# Closed-form expression would be:\n#   f(x) = round(x/exp(1))\n\n# See also:\n#   https://projecteuler.net/problem=183\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub maximum_split {\n    my ($n) = @_;\n\n    my $min = 1;\n    my $max = $n;\n\n    while ($min < $max) {\n        my $mid = ($min + $max) >> 1;\n\n        my $x_prev = ($mid - 1) * (log($n) - log($mid - 1));\n        my $x_curr = ($mid + 0) * (log($n) - log($mid + 0));\n        my $x_next = ($mid + 1) * (log($n) - log($mid + 1));\n\n        if ($x_prev < $x_curr and $x_curr > $x_next) {\n            return $mid;\n        }\n\n        if ($x_prev < $x_curr and $x_curr < $x_next) {\n            ++$min;\n        }\n        else {\n            --$max;\n        }\n    }\n\n    return $min;\n}\n\nsay maximum_split(8);       #=> 3\nsay maximum_split(11);      #=> 4\nsay maximum_split(24);      #=> 9\nsay maximum_split(5040);    #=> 1854\n"
  },
  {
    "path": "Math/maximum_square_remainder.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 31 August 2016\n# https://github.com/trizen\n\n# Find the maximum remainder of (a-1)^n + (a+1)^n when divided by a^2, for any positive integer n.\n\n# Example with a=7 and n=3:\n#\n#      (7-1)^3 + (7+1)^3 = 42  (mod 7^2)\n#\n# In turns out that 42 is the maximum remainder when a=7.\n\n# See also:\n#   https://oeis.org/A159469\n#   https://projecteuler.net/problem=120\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nsub max_square_remainder($n) {\n    $n * ($n - (2 - ($n % 2)));\n}\n\nforeach my $n (3 .. 20) {\n    say \"R($n) = \", max_square_remainder($n);\n}\n\n__END__\nR(3) = 6\nR(4) = 8\nR(5) = 20\nR(6) = 24\nR(7) = 42\nR(8) = 48\nR(9) = 72\nR(10) = 80\nR(11) = 110\nR(12) = 120\nR(13) = 156\nR(14) = 168\nR(15) = 210\nR(16) = 224\nR(17) = 272\nR(18) = 288\nR(19) = 342\nR(20) = 360\n"
  },
  {
    "path": "Math/meissel_lehmer_prime_count.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# 04 September 2025\n# https://github.com/trizen\n\n# Basic implementation of the Meissel–Lehmer algorithm for counting the number of primes <= n in sublinear time.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Meissel%E2%80%93Lehmer_algorithm\n\nuse 5.036;\nuse ntheory qw(:all);\n\nno warnings 'recursion';\n\n# Memoization\nmy %phi_cache;\nmy %pi_cache;\n\n# Recursive φ(n, a): numbers <= n not divisible by first a primes\nsub recursive_rough_count ($n, $P) {\n\n    sub ($n, $a) {\n\n        my $key = \"$n,$a\";\n\n        return $phi_cache{$key}\n          if exists $phi_cache{$key};\n\n        my $count = $n - ($n >> 1);\n\n        foreach my $j (1 .. $a - 1) {\n            my $np = divint($n, $P->[$j]);\n            last if ($np == 0);\n            $count -= __SUB__->($np, $j);\n        }\n\n        $phi_cache{$key} = $count;\n      }\n      ->($n, scalar @$P);\n}\n\n# P2 correction term\nsub P2($n, $a, $p_a) {\n\n    my $j     = $a;\n    my $lo    = $p_a + 1;\n    my $hi    = sqrtint($n);\n    my $count = 0;\n\n    foreach my $p (@{primes($lo, $hi)}) {\n        $count += meissel_lehmer_prime_count(divint($n, $p)) - $j++;\n    }\n\n    return $count;\n}\n\n# Meissel-Lehmer prime-counting function\nsub meissel_lehmer_prime_count($n) {\n\n    return $pi_cache{$n}\n      if exists $pi_cache{$n};\n\n    if ($n <= 10) {\n        return $pi_cache{$n} = (0, 0, 1, 2, 2, 3, 3, 4, 4, 4, 4)[$n];\n    }\n\n    my $cbrt = rootint($n, 3) + 1;\n    my @P    = @{primes($cbrt)};\n    my $a    = scalar @P;\n    my $p_a  = $P[-1];\n\n    my $phi = recursive_rough_count($n, \\@P);\n    my $p2  = P2($n, $a, $p_a);\n\n    my $result = $phi + $a - 1 - $p2;\n    $pi_cache{$n} = $result;\n}\n\n# --- Testing Loop ---\nfor my $n (1 .. 9) {\n\n    my $ten_pow_n = powint(10, $n);\n    my $pi_est    = meissel_lehmer_prime_count($ten_pow_n);\n    say \"pi(10^$n) = $pi_est\";\n\n    my $x   = int(rand($ten_pow_n));\n    my $ref = prime_count($x);                  # MPU's built-in π(x)\n    my $cmp = meissel_lehmer_prime_count($x);\n\n    die \"Mismatch at x=$x: $cmp != $ref\" unless $cmp == $ref;\n}\n\n__END__\npi(10^1) = 4\npi(10^2) = 25\npi(10^3) = 168\npi(10^4) = 1229\npi(10^5) = 9592\npi(10^6) = 78498\npi(10^7) = 664579\npi(10^8) = 5761455\npi(10^9) = 50847534\n"
  },
  {
    "path": "Math/mertens_function.pl",
    "content": "#!/usr/bin/perl\n\n# A simple implementation of a nice algorithm for computing the Mertens function:\n#   M(x) = Sum_{k=1..n} moebius(k)\n\n# Algorithm due to Marc Deleglise and Joel Rivat:\n#   https://projecteuclid.org/euclid.em/1047565447\n\n# This implementation is not particularly optimized.\n\n# See also:\n#   https://oeis.org/A002321\n#   https://oeis.org/A084237\n#   https://en.wikipedia.org/wiki/Mertens_function\n#   https://en.wikipedia.org/wiki/M%C3%B6bius_function\n\nuse 5.016;\nuse ntheory qw(sqrtint moebius);\nuse experimental qw(signatures);\n\nsub mertens_function ($x) {\n\n    my $u = sqrtint($x);\n\n    my @M  = (0);\n    my @mu = moebius(0, $u);        # list of Moebius(k) for k=0..floor(sqrt(n))\n\n    # Partial sums of the Moebius function:\n    #   M[n] = Sum_{k=1..n} moebius(k)\n\n    for my $i (1 .. $#mu) {\n        $M[$i] += $M[$i - 1] + $mu[$i];\n    }\n\n    my $sum = $M[$u];\n\n    foreach my $m (1 .. $u) {\n\n        $mu[$m] || next;\n\n        my $S1_t = 0;\n        foreach my $n (int($u / $m) + 1 .. sqrtint(int($x / $m))) {\n            $S1_t += $M[int($x / ($m * $n))];\n        }\n\n        my $S2_t = 0;\n        foreach my $n (sqrtint(int($x / $m)) + 1 .. int($x / $m)) {\n            $S2_t += $M[int($x / ($m * $n))];\n        }\n\n        $sum -= $mu[$m] * ($S1_t + $S2_t);\n    }\n\n    return $sum;\n}\n\nforeach my $n (1 .. 6) {\n    say \"M(10^$n) = \", mertens_function(10**$n);\n}\n\n__END__\nM(10^1) = -1\nM(10^2) = 1\nM(10^3) = 2\nM(10^4) = -23\nM(10^5) = -48\nM(10^6) = 212\nM(10^7) = 1037\nM(10^8) = 1928\nM(10^9) = -222\n"
  },
  {
    "path": "Math/mertens_function_fast.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 04 February 2019\n# https://github.com/trizen\n\n# A sublinear algorithm for computing the Mertens function (partial sums of the Möbius function).\n\n# Defined as:\n#\n#   M(n) = Sum_{k=1..n} μ(k)\n#\n# where μ(k) is the Möbius function.\n\n# Example:\n#   M(10^1) = -1\n#   M(10^2) = 1\n#   M(10^3) = 2\n#   M(10^4) = -23\n#   M(10^5) = -48\n#   M(10^6) = 212\n#   M(10^7) = 1037\n#   M(10^8) = 1928\n#   M(10^9) = -222\n\n# OEIS sequences:\n#   https://oeis.org/A008683 -- Möbius (or Moebius) function mu(n).\n#   https://oeis.org/A084237 -- M(10^n), where M(n) is Mertens's function.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Mertens_function\n#   https://en.wikipedia.org/wiki/M%C3%B6bius_function\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(moebius sqrtint rootint);\n\nsub mertens_function($n) {\n\n    my $lookup_size = 2 * rootint($n, 3)**2;\n\n    my @moebius_lookup = moebius(0, $lookup_size);\n    my @mertens_lookup = (0);\n\n    foreach my $i (1 .. $lookup_size) {\n        $mertens_lookup[$i] = $mertens_lookup[$i - 1] + $moebius_lookup[$i];\n    }\n\n    my %seen;\n\n    sub ($n) {\n\n        if ($n <= $lookup_size) {\n            return $mertens_lookup[$n];\n        }\n\n        if (exists $seen{$n}) {\n            return $seen{$n};\n        }\n\n        my $s = sqrtint($n);\n        my $M = 1;\n\n        foreach my $k (2 .. int($n / ($s + 1))) {\n            $M -= __SUB__->(int($n / $k));\n        }\n\n        foreach my $k (1 .. $s) {\n            $M -= $mertens_lookup[$k] * (int($n / $k) - int($n / ($k + 1)));\n        }\n\n        $seen{$n} = $M;\n\n    }->($n);\n}\n\nforeach my $n (1 .. 9) {    # takes ~1.6 seconds\n    say \"M(10^$n) = \", mertens_function(10**$n);\n}\n"
  },
  {
    "path": "Math/miller-rabin_deterministic_primality_test.pl",
    "content": "#!/usr/bin/perl\n\n# Miller-Rabin deterministic primality test.\n\n# Theorem (Miller, 1976):\n#   If the Generalized Riemann hypothesis is true, then there is a constant C such that\n#   primality of `n` is the same as every a <= C*(log(n))^2 being a Miller-Rabin witness for `n`.\n\n# Bach (1984) showed that we can use C = 2.\n\n# Assuming the GRH, this primality test runs in polynomial time.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Miller%E2%80%93Rabin_primality_test\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse List::Util qw(min);\nuse ntheory qw(valuation powmod);\n\nsub is_provable_prime {\n    my ($n) = @_;\n\n    return 1 if $n == 2;\n    return 0 if $n < 2 or $n % 2 == 0;\n\n    my $d = $n - 1;\n    my $s = valuation($d, 2);\n\n    $d >>= $s;\n\n  LOOP: for my $k (2 .. min($n-1, 2*log($n)**2)) {\n\n        my $x = powmod($k, $d, $n);\n        next if $x == 1 or $x == $n - 1;\n\n        for (1 .. $s - 1) {\n            $x = ($x * $x) % $n;\n            return 0  if $x == 1;\n            next LOOP if $x == $n - 1;\n        }\n        return 0;\n    }\n    return 1;\n}\n\nmy $count = 0;\nmy $limit = 100000;\n\nforeach my $n (1 .. $limit) {\n    if (is_provable_prime($n)) {\n        ++$count;\n    }\n}\n\nsay \"There are $count primes <= $limit\";\n"
  },
  {
    "path": "Math/miller-rabin_deterministic_primality_test_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Miller-Rabin deterministic primality test.\n\n# Theorem (Miller, 1976):\n#   If the Generalized Riemann hypothesis is true, then there is a constant C such that\n#   primality of `n` is the same as every a <= C*(log(n))^2 being a Miller-Rabin witness for `n`.\n\n# Eric Bach (1984) showed that we can use C = 2.\n\n# See also:\n#   https://rosettacode.org/wiki/Miller%E2%80%93Rabin_primality_test#Perl\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(valuation powmod);\n\nuse Math::GMPz;\nuse Math::MPFR;\n\nsub is_provable_prime {\n    my ($n) = @_;\n\n    return 1 if $n == 2;\n    return 0 if $n < 2 or $n % 2 == 0;\n\n    return 1 if $n == 5;\n    return 1 if $n == 7;\n    return 1 if $n == 11;\n    return 1 if $n == 13;\n\n    my $d = $n - 1;\n    my $s = valuation($d, 2);\n\n    $d >>= $s;\n\n    my $bound = ref($n) eq 'Math::GMPz' ? do {\n        my $r = Math::MPFR::Rmpfr_init2(64);\n        Math::MPFR::Rmpfr_set_z($r, $n, 0);\n        Math::MPFR::Rmpfr_log($r, $r, 0);\n        2 * Math::MPFR::Rmpfr_get_d($r, 0)**2;\n    } : 2 * log($n)**2;\n\n  LOOP: for my $k (1 .. $bound) {\n\n        my $x = powmod($k, $d, $n);\n\n        if (ref($x) or $x >= (~0 >> 1)) {\n            $x = Math::GMPz->new(\"$x\");\n        }\n\n        next if $x == 1 or $x == $n - 1;\n\n        for (1 .. $s - 1) {\n            $x = ($x * $x) % $n;\n            return 0  if $x == 1;\n            next LOOP if $x == $n - 1;\n        }\n        return 0;\n    }\n    return 1;\n}\n\n# Primes\nsay is_provable_prime(Math::GMPz->new(2)**89 - 1)  ? 'prime' : 'error';\nsay is_provable_prime(Math::GMPz->new(2)**107 - 1) ? 'prime' : 'error';\nsay is_provable_prime(Math::GMPz->new(2)**127 - 1) ? 'prime' : 'error';\nsay is_provable_prime(Math::GMPz->new('115547929908077082437116944109458314609946651910092587495187962466088019331251')) ? 'prime' : 'error';\n\n# Composites\nsay is_provable_prime(Math::GMPz->new('142899381901'))                                       ? 'error' : 'composite';\nsay is_provable_prime(Math::GMPz->new('92737632541325090700295531'))                         ? 'error' : 'composite';\nsay is_provable_prime(Math::GMPz->new('200000000135062271492802271468294969951'))            ? 'error' : 'composite';\nsay is_provable_prime(Math::GMPz->new('48793204382746801501446610630739608190006929723969')) ? 'error' : 'composite';\nsay is_provable_prime(Math::GMPz->new('25195908475657893494027183240048398571429282126204032027777137836043662020707595556264018525880784406918290641249515082189298559149176184502808489120072844992687392807287776735971418347270261896375014971824691165077613379859095700097330459748808428401797429100642458691817195118746121515172654632282216869987549182422433637259085141865462043576798423387184774447920739934236584823824281198163815010674810451660377306056201619676256133844143603833904414952634432190114657544454178424020924616515723350778707749817125772467962926386356373289912154831438167899885040445364023527381951378636564391212010397122822120720357')) ? 'error' : 'composite';\n"
  },
  {
    "path": "Math/miller-rabin_factorization_method.pl",
    "content": "#!/usr/bin/perl\n\n# Factorization method, based on the Miller-Rabin primality test.\n# Described in the book \"Elementary Number Theory\", by Peter Hackman.\n\n# Works best on Carmichael numbers.\n\n# Example:\n#   N   = 1729\n#   N-1 = 2^6 * 27\n\n# Then, we find that:\n#       2^(2*27) == 1065 != -1 (mod N)\n# and\n#       2^(4*27) == 1 (mod N)\n\n# This proves that N is composite and gives the following factorization:\n#   x = 2^(2*27) (mod N)\n#   N = gcd(x+1, N) * gcd(x-1, N)\n#   N = gcd(1065+1, N) * gcd(1065-1, N)\n#   N = 13 * 133\n\n# See also:\n#   https://www.math.waikato.ac.nz/~kab/509/bigbook.pdf\n#   https://en.wikipedia.org/wiki/Miller-Rabin_primality_test\n\nuse 5.020;\nuse warnings;\n\nuse Math::GMPz;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub miller_rabin_factor ($n, $tries = 100) {\n\n    if (ref($n) ne 'Math::GMPz') {\n        $n = Math::GMPz->new(\"$n\");\n    }\n\n    my $D = $n - 1;\n    my $s = valuation($D, 2);\n    my $r = $s - 1;\n    my $d = $D >> $s;\n\n    for (1 .. $tries) {\n\n        my $p = random_prime(1e7);\n        my $x = powmod($p, $d, $n);\n\n        for (0 .. $r) {\n\n            last if (($x == 1) || ($x == $D));\n\n            foreach my $i (1, -1) {\n                my $g = gcd($x + $i, $n);\n                if ($g > 1 and $g < $n) {\n                    return $g;\n                }\n            }\n\n            $x = mulmod($x, $x, $n);\n        }\n    }\n\n    return 1;\n}\n\nsay miller_rabin_factor(\"1729\");\nsay miller_rabin_factor(\"335603208601\");\nsay miller_rabin_factor(\"30459888232201\");\nsay miller_rabin_factor(\"162021627721801\");\nsay miller_rabin_factor(\"1372144392322327801\");\nsay miller_rabin_factor(\"7520940423059310542039581\");\nsay miller_rabin_factor(\"8325544586081174440728309072452661246289\");\nsay miller_rabin_factor(\"181490268975016506576033519670430436718066889008242598463521\");\nsay miller_rabin_factor(\"57981220983721718930050466285761618141354457135475808219583649146881\");\nsay miller_rabin_factor(\"131754870930495356465893439278330079857810087607720627102926770417203664110488210785830750894645370240615968198960237761\");\n"
  },
  {
    "path": "Math/modular_bell_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# A fast algorithm for computing the n-th Bell number modulo a native integer.\n\n# See also:\n#   https://oeis.org/A325630 -- Numbers k such that Bell(k) == 0 (mod k).\n#   https://en.wikipedia.org/wiki/Bell_number\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\nuse ntheory qw(addmod);\nuse experimental qw(signatures);\n\nsub bell_number ($n, $m) {\n\n    my @acc;\n\n    my $t    = 0;\n    my $bell = 1;\n\n    foreach my $k (1 .. $n) {\n\n        $t = $bell;\n\n        foreach my $j (@acc) {\n            $t = addmod($t, $j, $m);\n            $j = $t;\n        }\n\n        unshift @acc, $bell;\n        $bell = $acc[-1];\n    }\n\n    $bell;\n}\n\nsay bell_number(35,  35);      #=> 0\nsay bell_number(35,  1234);    #=> 852\nsay bell_number(123, 4171);    #=> 3567\n"
  },
  {
    "path": "Math/modular_bell_numbers_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# A fast algorithm for computing the n-th Bell number modulo a native integer.\n\n# See also:\n#   https://oeis.org/A325630 -- Numbers k such that Bell(k) == 0 (mod k).\n#   https://en.wikipedia.org/wiki/Bell_number\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\nuse experimental qw(signatures);\n\nsub bell_number ($n, $m) {\n\n    my @acc;\n\n    my $t    = Math::GMPz::Rmpz_init();\n    my $bell = Math::GMPz::Rmpz_init_set_ui(1);\n\n    foreach my $k (1 .. $n) {\n\n        Math::GMPz::Rmpz_set($t, $bell);\n\n        foreach my $item (@acc) {\n            Math::GMPz::Rmpz_add($t, $t, $item);\n            Math::GMPz::Rmpz_mod_ui($t, $t, $m);\n            Math::GMPz::Rmpz_set($item, $t);\n        }\n\n        unshift @acc, Math::GMPz::Rmpz_init_set($bell);\n        $bell = Math::GMPz::Rmpz_init_set($acc[-1]);\n    }\n\n    $bell;\n}\n\nsay bell_number(35,  35);      #=> 0\nsay bell_number(35,  1234);    #=> 852\nsay bell_number(123, 4171);    #=> 3567\n"
  },
  {
    "path": "Math/modular_binomial.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 08 February 2017\n# Website: https://github.com/trizen\n\n# Algorithm for binomial(n, k) mod m.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(forprimes powmod vecsum todigits);\n\nsub factorial_power ($n, $p) {\n    ($n - vecsum(todigits($n, $p))) / ($p - 1);\n}\n\nsub modular_binomial ($n, $k, $m) {\n\n    my $j    = $n - $k;\n    my $prod = 1;\n\n    forprimes {\n        my $p = factorial_power($n, $_);\n\n        if ($_ <= $k) {\n            $p -= factorial_power($k, $_);\n        }\n\n        if ($_ <= $j) {\n            $p -= factorial_power($j, $_);\n        }\n\n        if ($p > 0) {\n            $prod *= ($p == 1) ? ($_ % $m) : powmod($_, $p, $m);\n            $prod %= $m;\n        }\n    } $n;\n\n    return $prod;\n}\n\nsay modular_binomial(100, 50, 139);        #=> 71\nsay modular_binomial(124, 42, 1234567);    #=> 395154\n"
  },
  {
    "path": "Math/modular_binomial_fast.pl",
    "content": "#!/usr/bin/perl\n\n# Efficient algorithm for computing `binomial(n, k) mod m`, based on the factorization of `m`.\n\n# Algorithm by Andrew Granville:\n#     https://www.scribd.com/document/344759427/BinCoeff-pdf\n\n# Algorithm translated from (+some optimizations):\n#   https://github.com/hellman/libnum/blob/master/libnum/modular.py\n\n# Translated by: Trizen\n# Date: 29 September 2017\n# Edit: 28 April 2022\n# https://github.com/trizen\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub modular_binomial ($n, $k, $m) {\n\n    if ($m == 0) {\n        return undef;\n    }\n\n    if ($m == 1) {\n        return 0;\n    }\n\n    if ($k < 0) {\n        $k = subint($n, $k);\n    }\n\n    if ($k < 0) {\n        return 0;\n    }\n\n    if ($n < 0) {\n        return modint(mulint(powint(-1, $k), __SUB__->(subint($k, $n) - 1, $k, $m)), $m);\n    }\n\n    if ($k > $n) {\n        return 0;\n    }\n\n    if ($k == 0 or $k == $n) {\n        return modint(1, $m);\n    }\n\n    if ($k == 1 or $k == subint($n, 1)) {\n        return modint($n, $m);\n    }\n\n    my @congruences;\n\n    foreach my $pair (factor_exp(absint($m))) {\n        my ($p, $e) = @$pair;\n\n        if ($e == 1) {\n            push @congruences, [lucas_theorem($n, $k, $p), $p];\n        }\n        else {\n            push @congruences, [modular_binomial_prime_power($n, $k, $p, $e), powint($p, $e)];\n        }\n    }\n\n    modint(chinese(@congruences), $m);\n}\n\n#<<<\n#~ sub factorial_prime_pow ($n, $p) {\n    #~ divint(subint($n, sumdigits($n, $p)), subint($p, 1));\n#~ }\n#>>>\n\nsub factorial_prime_pow ($n, $p) {\n    my $count = 0;\n    my $ppow  = $p;\n    while ($ppow <= $n) {\n        $count = addint($count, divint($n, $ppow));\n        $ppow  = mulint($ppow, $p);\n    }\n    return $count;\n}\n\nsub binomial_prime_pow ($n, $k, $p) {\n#<<<\n      factorial_prime_pow($n,      $p)\n    - factorial_prime_pow($k,      $p)\n    - factorial_prime_pow(subint($n, $k), $p);\n#>>>\n}\n\nsub factorial_without_prime ($n, $p, $pk) {\n    return 1 if ($n <= 1);\n\n    if ($p > $n) {\n        return factorialmod($n, $pk);\n    }\n\n    my $r = 1;\n    my $t = 0;\n\n    foreach my $v (1 .. $n) {\n        if (++$t == $p) {\n            $t = 0;\n        }\n        else {\n            $r = mulmod($r, $v, $pk);\n        }\n    }\n\n    return $r;\n}\n\nsub lucas_theorem ($n, $k, $p) {    # p is prime\n\n    my $r = 1;\n\n    while ($k) {\n\n        my $np = modint($n, $p);\n        my $kp = modint($k, $p);\n\n        if ($kp > $np) { return 0 }\n\n        my $rp = subint($np, $kp);\n\n        my $x = factorialmod($np, $p);\n        my $y = factorialmod($kp, $p);\n        my $z = factorialmod($rp, $p);\n\n        $y = mulmod($y, $z, $p);\n        $x = divmod($x, $y, $p);\n\n        $r = mulmod($r, $x, $p);\n\n        $n = divint($n, $p);\n        $k = divint($k, $p);\n    }\n\n    return $r;\n}\n\nsub binomial_non_prime_part ($n, $k, $p, $e) {\n\n    my $pe = powint($p, $e);\n    my $r  = subint($n, $k);\n\n    my $acc     = 1;\n    my @fact_pe = (1);\n\n    if ($pe < ~0 and $p < $n) {\n        my $count = 0;\n        foreach my $x (1 .. vecmin(1e4, $pe - 1)) {\n            if (++$count == $p) {\n                $count = 0;\n            }\n            else {\n                $acc = mulmod($acc, $x, $pe);\n            }\n            push @fact_pe, $acc;\n        }\n    }\n\n    my $top         = 1;\n    my $bottom      = 1;\n    my $is_negative = 0;\n    my $digits      = 0;\n\n    while ($n) {\n\n        if ($digits >= $e) {\n            $is_negative ^= modint($n, 2);\n            $is_negative ^= modint($r, 2);\n            $is_negative ^= modint($k, 2);\n        }\n\n        my $np = modint($n, $pe);\n        my $rp = modint($r, $pe);\n        my $kp = modint($k, $pe);\n\n#<<<\n        $top    = mulmod($top,    ($fact_pe[$np] // factorial_without_prime($np, $p, $pe)), $pe);\n        $bottom = mulmod($bottom, ($fact_pe[$rp] // factorial_without_prime($rp, $p, $pe)), $pe);\n        $bottom = mulmod($bottom, ($fact_pe[$kp] // factorial_without_prime($kp, $p, $pe)), $pe);\n#>>>\n\n        $n = divint($n, $p);\n        $r = divint($r, $p);\n        $k = divint($k, $p);\n\n        ++$digits;\n    }\n\n    my $res = divmod($top, $bottom, $pe);\n\n    if ($is_negative and ($p != 2 or $e < 3)) {\n        $res = subint($pe, $res);\n    }\n\n    return $res;\n}\n\nsub modular_binomial_prime_power ($n, $k, $p, $e) {\n    my $pow = binomial_prime_pow($n, $k, $p);\n\n    if ($pow >= $e) {\n        return 0;\n    }\n\n    my $er = $e - $pow;\n    my $r  = modint(binomial_non_prime_part($n, $k, $p, $er), powint($p, $er));\n\n    my $pe = powint($p, $e);\n    return mulmod(powmod($p, $pow, $pe), $r, $pe);\n}\n\nuse Test::More tests => 44;\n\nis(modular_binomial(10, 2, 43), 2);\nis(modular_binomial(10, 8, 43), 2);\n\nis(modular_binomial(10, 2, 24), 21);\nis(modular_binomial(10, 8, 24), 21);\n\nis(modular_binomial(100, 42, -127), binomial(100, 42) % -127);\n\nis(modular_binomial(12,   5,   100000),  792);\nis(modular_binomial(16,   4,   100000),  1820);\nis(modular_binomial(100,  50,  139),     71);\nis(modular_binomial(1000, 10,  1243),    848);\nis(modular_binomial(124,  42,  1234567), 395154);\nis(modular_binomial(1e9,  1e4, 1234567), 833120);\nis(modular_binomial(1e10, 1e5, 1234567), 589372);\n\nis(modular_binomial(1e10,  1e5, 4233330243), 3403056024);\nis(modular_binomial(-1e10, 1e5, 4233330243), 2865877173);\n\nis(modular_binomial(1e10, 1e4, factorial(13)), 1845043200);\nis(modular_binomial(1e10, 1e5, factorial(13)), 1556755200);\nis(modular_binomial(1e10, 1e6, factorial(13)), 5748019200);\n\nis(modular_binomial(-1e10, 1e4, factorial(13)), 4151347200);\nis(modular_binomial(-1e10, 1e5, factorial(13)), 1037836800);\nis(modular_binomial(-1e10, 1e6, factorial(13)), 2075673600);\n\nis(modular_binomial(3, 1, 9),  binomial(3, 1) % 9);\nis(modular_binomial(4, 1, 16), binomial(4, 1) % 16);\n\nis(modular_binomial(1e9,  1e5, 43 * 97 * 503),         585492);\nis(modular_binomial(1e9,  1e6, 5041689707),            15262431);\nis(modular_binomial(1e7,  1e5, 43**2 * 97**3 * 13**4), 1778017500428);\nis(modular_binomial(1e7,  1e5, 42**2 * 97**3 * 13**4), 10015143223176);\nis(modular_binomial(1e9,  1e5, 12345678910),           4517333900);\nis(modular_binomial(1e9,  1e6, 13**2 * 5**6),          2598375);\nis(modular_binomial(1e10, 1e5, 1234567),               589372);\n\nis(modular_binomial(1e5,     1e3, 43),                 binomial(1e5,     1e3) % 43);\nis(modular_binomial(1e5,     1e3, 43 * 97),            binomial(1e5,     1e3) % (43 * 97));\nis(modular_binomial(1e5,     1e3, 43 * 97 * 43),       binomial(1e5,     1e3) % (43 * 97 * 43));\nis(modular_binomial(1e5,     1e3, 43 * 97 * (5**5)),   binomial(1e5,     1e3) % (43 * 97 * (5**5)));\nis(modular_binomial(1e5,     1e3, next_prime(1e4)**2), binomial(1e5,     1e3) % next_prime(1e4)**2);\nis(modular_binomial(1e5,     1e3, next_prime(1e4)),    binomial(1e5,     1e3) % next_prime(1e4));\nis(modular_binomial(1e6,     1e3, next_prime(1e5)),    binomial(1e6,     1e3) % next_prime(1e5));\nis(modular_binomial(1e6,     1e3, next_prime(1e7)),    binomial(1e6,     1e3) % next_prime(1e7));\nis(modular_binomial(1234567, 1e3, factorial(20)),      binomial(1234567, 1e3) % factorial(20));\nis(modular_binomial(1234567, 1e4, factorial(20)),      binomial(1234567, 1e4) % factorial(20));\n\nis(modular_binomial(1e6, 1e3, powint(2, 128) + 1), binomial(1e6, 1e3) % (powint(2, 128) + 1));\nis(modular_binomial(1e6, 1e3, powint(2, 128) - 1), binomial(1e6, 1e3) % (powint(2, 128) - 1));\n\nis(modular_binomial(1e6, 1e4, (powint(2, 128) + 1)**2), binomial(1e6, 1e4) % ((powint(2, 128) + 1)**2));\nis(modular_binomial(1e6, 1e4, (powint(2, 128) - 1)**2), binomial(1e6, 1e4) % ((powint(2, 128) - 1)**2));\nis(modular_binomial(-10, -9,  -10), binomial(-10, -9) % -10);\n\nsay(\"binomial(10^10, 10^5) mod 13! = \", modular_binomial(1e10, 1e5, factorial(13)));\n\nsay modular_binomial(12,   5,   100000);     #=> 792\nsay modular_binomial(16,   4,   100000);     #=> 1820\nsay modular_binomial(100,  50,  139);        #=> 71\nsay modular_binomial(1000, 10,  1243);       #=> 848\nsay modular_binomial(124,  42,  1234567);    #=> 395154\nsay modular_binomial(1e9,  1e4, 1234567);    #=> 833120\nsay modular_binomial(1e10, 1e5, 1234567);    #=> 589372\n\n__END__\nmy $upto = 10;\nforeach my $n (-$upto .. $upto) {\n    foreach my $k (-$upto .. $upto) {\n        foreach my $m (-$upto .. $upto) {\n            next if ($m == 0);\n            say \"Testing: binomial($n, $k, $m)\";\n            is(modular_binomial($n, $k, $m), binomial($n, $k) % $m);\n        }\n    }\n}\n"
  },
  {
    "path": "Math/modular_binomial_faster.pl",
    "content": "#!/usr/bin/perl\n\n# Translated by: Trizen\n# Date: 27 April 2022\n# https://github.com/trizen\n\n# Fast algorithm for computing the binomial coefficient modulo some integer m.\n\n# The implementation is based on Lucas' Theorem and its generalization given in the paper\n# Andrew Granville \"The Arithmetic Properties of Binomial Coefficients\", In Proceedings of\n# the Organic Mathematics Workshop, Simon Fraser University, December 12-14, 1995.\n\n# Translation of binomod.gp v1.5 by Max Alekseyev, with some minor optimizations.\n\n# See also:\n#   https://home.gwu.edu/~maxal/gpscripts/\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\n\nsub factorial_without_prime ($n, $p, $pk, $from, $count, $res) {\n    return 1 if ($n <= 1);\n\n    if ($p > $n) {\n        return factorialmod($n, $pk);\n    }\n\n    if ($$from == $n) {\n        return $$res;\n    }\n\n    if ($$from > $n) {\n        $$from  = 0;\n        $$count = 0;\n        $$res   = 1;\n    }\n\n    my $r = $$res;\n    my $t = $$count;\n\n    foreach my $v ($$from + 1 .. $n) {\n        if (++$t == $p) {\n            $t = 0;\n        }\n        else {\n            $r = mulmod($r, $v, $pk);\n        }\n    }\n\n    $$res   = $r;\n    $$count = $t;\n    $$from  = $n;\n\n    return $r;\n}\n\nsub lucas_theorem ($n, $k, $p) {    # p is prime\n\n    my $r = 1;\n\n    while ($k) {\n\n        my $np = modint($n, $p);\n        my $kp = modint($k, $p);\n\n        if ($kp > $np) { return 0 }\n\n        my $rp = subint($np, $kp);\n\n        my $x = factorialmod($np, $p);\n        my $y = factorialmod($kp, $p);\n        my $z = factorialmod($rp, $p);\n\n        $y = mulmod($y, $z, $p);\n        $x = divmod($x, $y, $p);\n\n        $r = mulmod($r, $x, $p);\n\n        $n = divint($n, $p);\n        $k = divint($k, $p);\n    }\n\n    return $r;\n}\n\nsub modular_binomial ($n, $k, $m) {\n\n    if ($m == 0) {\n        return undef;\n    }\n\n    if ($m == 1) {\n        return 0;\n    }\n\n    if ($k < 0) {\n        $k = subint($n, $k);\n    }\n\n    if ($k < 0) {\n        return 0;\n    }\n\n    if ($n < 0) {\n        return modint(mulint(powint(-1, $k), __SUB__->(subint($k, $n) - 1, $k, $m)), $m);\n    }\n\n    if ($k > $n) {\n        return 0;\n    }\n\n    if ($k == 0 or $k == $n) {\n        return modint(1, $m);\n    }\n\n    if ($k == 1 or $k == subint($n, 1)) {\n        return modint($n, $m);\n    }\n\n    my @F;\n\n    foreach my $pp (factor_exp(absint($m))) {\n        my ($p, $q) = @$pp;\n\n        if ($q == 1) {\n            push @F, [lucas_theorem($n, $k, $p), $p];\n            next;\n        }\n\n        my $d = logint($n, $p) + 1;\n\n        my (@np, @kp);\n\n        do {\n            my $pi = 1;\n            foreach my $i (0 .. $d) {\n                push @np, modint(divint($n, $pi), $p);\n                push @kp, modint(divint($k, $pi), $p);\n                $pi = mulint($pi, $p);\n            }\n        };\n\n        my @e;\n\n        foreach my $i (0 .. $d) {\n            $e[$i] = ($np[$i] < ($kp[$i] + (($i > 0) ? $e[$i - 1] : 0))) ? 1 : 0;\n        }\n\n        for (my $i = $d - 1 ; $i >= 0 ; --$i) {\n            $e[$i] += $e[$i + 1];\n        }\n\n        if ($e[0] >= $q) {\n            push @F, [0, powint($p, $q)];\n            next;\n        }\n\n        my $rq = $q - $e[0];\n\n        my $pq  = powint($p, $q);\n        my $prq = powint($p, $rq);\n\n        my (@N, @K, @R);\n\n        do {\n            my $pi = 1;\n            my $r  = subint($n, $k);\n            foreach my $i (0 .. $d) {\n                push @N, modint(divint($n, $pi), $prq);\n                push @K, modint(divint($k, $pi), $prq);\n                push @R, modint(divint($r, $pi), $prq);\n                $pi = mulint($pi, $p);\n            }\n        };\n\n        my @NKR = (\n                   sort { $a->[3] <=> $b->[3] }\n                   map  { [$N[$_], $K[$_], $R[$_], $N[$_] + $K[$_] + $R[$_]] } 0 .. $#N\n                  );\n\n        @N = map { $_->[0] } @NKR;\n        @K = map { $_->[1] } @NKR;\n        @R = map { $_->[2] } @NKR;\n\n        my %acc  = (0 => 1);\n        my $nfac = 1;\n\n        if ($prq < ~0 and $p < $n) {\n            my $count = 0;\n            foreach my $k (1 .. vecmin(vecmax(@N, @K, @R), 1e4)) {\n                if (++$count == $p) {\n                    $count = 0;\n                }\n                else {\n                    $nfac = mulmod($nfac, $k, $prq);\n                }\n                $acc{$k} = $nfac;\n            }\n        }\n\n        my $v = powmod($p, $e[0], $pq);\n\n        do {\n            my $from  = 0;\n            my $count = 0;\n            my $res   = 1;\n\n            foreach my $j (0 .. $d) {\n\n                my @pairs;\n                my ($x, $y, $z);\n\n                ($x = $acc{$N[$j]}) // push(@pairs, [\\$x, $N[$j]]);\n                ($y = $acc{$K[$j]}) // push(@pairs, [\\$y, $K[$j]]);\n                ($z = $acc{$R[$j]}) // push(@pairs, [\\$z, $R[$j]]);\n\n                foreach my $pair (sort { $a->[1] <=> $b->[1] } @pairs) {\n                    ${$pair->[0]} = factorial_without_prime($pair->[1], $p, $prq, \\$from, \\$count, \\$res);\n                }\n\n                $v = mulmod($v, divmod($x, mulmod($y, $z, $pq), $pq), $pq);\n            }\n        };\n\n        if (($p > 2 or $rq < 3) and $rq <= scalar(@e)) {\n            $v = mulmod($v, powint(-1, $e[$rq - 1]), $pq);\n        }\n\n        push @F, [$v, $pq];\n    }\n\n    modint(chinese(@F), $m);\n}\n\n#\n## Run some tests\n#\n\nuse Test::More tests => 44;\n\nis(modular_binomial(10, 2, 43), 2);\nis(modular_binomial(10, 8, 43), 2);\n\nis(modular_binomial(10, 2, 24), 21);\nis(modular_binomial(10, 8, 24), 21);\n\nis(modular_binomial(100, 42, -127), binomial(100, 42) % -127);\n\nis(modular_binomial(12,   5,   100000),  792);\nis(modular_binomial(16,   4,   100000),  1820);\nis(modular_binomial(100,  50,  139),     71);\nis(modular_binomial(1000, 10,  1243),    848);\nis(modular_binomial(124,  42,  1234567), 395154);\nis(modular_binomial(1e9,  1e4, 1234567), 833120);\nis(modular_binomial(1e10, 1e5, 1234567), 589372);\n\nis(modular_binomial(1e10,  1e5, 4233330243), 3403056024);\nis(modular_binomial(-1e10, 1e5, 4233330243), 2865877173);\n\nis(modular_binomial(1e10, 1e4, factorial(13)), 1845043200);\nis(modular_binomial(1e10, 1e5, factorial(13)), 1556755200);\nis(modular_binomial(1e10, 1e6, factorial(13)), 5748019200);\n\nis(modular_binomial(-1e10, 1e4, factorial(13)), 4151347200);\nis(modular_binomial(-1e10, 1e5, factorial(13)), 1037836800);\nis(modular_binomial(-1e10, 1e6, factorial(13)), 2075673600);\n\nis(modular_binomial(3, 1, 9),  binomial(3, 1) % 9);\nis(modular_binomial(4, 1, 16), binomial(4, 1) % 16);\n\nis(modular_binomial(1e9,  1e5, 43 * 97 * 503),         585492);\nis(modular_binomial(1e9,  1e6, 5041689707),            15262431);\nis(modular_binomial(1e7,  1e5, 43**2 * 97**3 * 13**4), 1778017500428);\nis(modular_binomial(1e7,  1e5, 42**2 * 97**3 * 13**4), 10015143223176);\nis(modular_binomial(1e9,  1e5, 12345678910),           4517333900);\nis(modular_binomial(1e9,  1e6, 13**2 * 5**6),          2598375);\nis(modular_binomial(1e10, 1e5, 1234567),               589372);\n\nis(modular_binomial(1e5,     1e3, 43),                 binomial(1e5,     1e3) % 43);\nis(modular_binomial(1e5,     1e3, 43 * 97),            binomial(1e5,     1e3) % (43 * 97));\nis(modular_binomial(1e5,     1e3, 43 * 97 * 43),       binomial(1e5,     1e3) % (43 * 97 * 43));\nis(modular_binomial(1e5,     1e3, 43 * 97 * (5**5)),   binomial(1e5,     1e3) % (43 * 97 * (5**5)));\nis(modular_binomial(1e5,     1e3, next_prime(1e4)**2), binomial(1e5,     1e3) % next_prime(1e4)**2);\nis(modular_binomial(1e5,     1e3, next_prime(1e4)),    binomial(1e5,     1e3) % next_prime(1e4));\nis(modular_binomial(1e6,     1e3, next_prime(1e5)),    binomial(1e6,     1e3) % next_prime(1e5));\nis(modular_binomial(1e6,     1e3, next_prime(1e7)),    binomial(1e6,     1e3) % next_prime(1e7));\nis(modular_binomial(1234567, 1e3, factorial(20)),      binomial(1234567, 1e3) % factorial(20));\nis(modular_binomial(1234567, 1e4, factorial(20)),      binomial(1234567, 1e4) % factorial(20));\n\nis(modular_binomial(1e6, 1e3, powint(2, 128) + 1), binomial(1e6, 1e3) % (powint(2, 128) + 1));\nis(modular_binomial(1e6, 1e3, powint(2, 128) - 1), binomial(1e6, 1e3) % (powint(2, 128) - 1));\n\nis(modular_binomial(1e6, 1e4, (powint(2, 128) + 1)**2), binomial(1e6, 1e4) % ((powint(2, 128) + 1)**2));\nis(modular_binomial(1e6, 1e4, (powint(2, 128) - 1)**2), binomial(1e6, 1e4) % ((powint(2, 128) - 1)**2));\nis(modular_binomial(-10, -9,  -10), binomial(-10, -9) % -10);\n\nsay(\"binomial(10^10, 10^5) mod 13! = \", modular_binomial(1e10, 1e5, factorial(13)));\n\n__END__\nmy $upto = 10;\nforeach my $n (-$upto .. $upto) {\n    foreach my $k (-$upto .. $upto) {\n        foreach my $m (-$upto .. $upto) {\n            next if ($m == 0);\n            say \"Testing: binomial($n, $k, $m)\";\n            is(modular_binomial($n, $k, $m), binomial($n, $k) % $m);\n        }\n    }\n}\n"
  },
  {
    "path": "Math/modular_binomial_faster_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Translated by: Trizen\n# Date: 18 March 2026\n# https://github.com/trizen\n\n# Fast algorithm for computing the binomial coefficient modulo some integer m.\n\n# The implementation is based on Lucas' Theorem and its generalization given in the paper\n# Andrew Granville \"The Arithmetic Properties of Binomial Coefficients\", In Proceedings of\n# the Organic Mathematics Workshop, Simon Fraser University, December 12-14, 1995.\n\n# Translation of binomod.gp v1.5 by Max Alekseyev, with some minor optimizations.\n\n# See also:\n#   https://home.gwu.edu/~maxal/gpscripts/\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory 0.74           qw(:all);\nuse Math::Prime::Util::GMP qw();\nuse Math::Sidef            qw();\n\nprime_set_config(bigint => \"Math::BigInt\");\n\nsub test_binomialmod($n, $k, $m) {\n    Math::Sidef::binomialmod($n, $k, $m);\n}\n\nsub _factorial_without_prime {\n    my ($n, $p, $pk, $from, $count, $res) = @_;\n\n    return 1 if ($n <= 1);\n\n    if ($p > $n) {\n        return factorialmod($n, $pk);\n    }\n\n    if ($$from == $n) {\n        return $$res;\n    }\n\n    if ($$from > $n) {\n        $$from  = 0;\n        $$count = 0;\n        $$res   = 1;\n    }\n\n    my $r = $$res;\n    my $t = $$count;\n\n    foreach my $v ($$from + 1 .. $n) {\n        if (++$t == $p) {\n            $t = 0;\n        }\n        else {\n            $r = mulmod($r, $v, $pk);\n        }\n    }\n\n    $$res   = $r;\n    $$count = $t;\n    $$from  = $n;\n\n    return $r;\n}\n\nsub _small_k_binomialmod {\n    my ($n_val, $k_val, $m_val, $p) = @_;\n\n    $n_val = Math::GMPz::Rmpz_init_set_str($n_val, 10) if ref($n_val) ne 'Math::GMPz';\n    $m_val = Math::GMPz::Rmpz_init_set_str($m_val, 10) if ref($m_val) ne 'Math::GMPz';\n\n    if (!$p or $k_val <= 1e5) {\n        my $bin = Math::GMPz::Rmpz_init();\n        if (Math::GMPz::Rmpz_fits_ulong_p($n_val) and Math::GMPz::Rmpz_cmp_ui($n_val, 1e5) <= 0) {\n            Math::GMPz::Rmpz_bin_uiui($bin, Math::GMPz::Rmpz_get_ui($n_val), $k_val);\n        }\n        else {\n            Math::GMPz::Rmpz_bin_ui($bin, $n_val, $k_val);\n        }\n        Math::GMPz::Rmpz_mod($bin, $bin, $m_val);\n        return $bin;\n    }\n\n    my $v = 0;\n    state $num_mult = Math::GMPz::Rmpz_init_nobless();\n    state $den_mult = Math::GMPz::Rmpz_init_nobless();\n    state $temp     = Math::GMPz::Rmpz_init_nobless();\n\n    Math::GMPz::Rmpz_set_ui($num_mult, 1);\n    Math::GMPz::Rmpz_set_ui($den_mult, 1);\n\n    for my $i (0 .. $k_val - 1) {\n        Math::GMPz::Rmpz_sub_ui($temp, $n_val, $i);\n        while (Math::GMPz::Rmpz_divisible_ui_p($temp, $p)) {\n            Math::GMPz::Rmpz_divexact_ui($temp, $temp, $p);\n            ++$v;\n        }\n        Math::GMPz::Rmpz_mul($num_mult, $num_mult, $temp);\n        Math::GMPz::Rmpz_mod($num_mult, $num_mult, $m_val);\n\n        my $den = $i + 1;\n        while ($den % $p == 0) {\n            $den = Math::Prime::Util::divint($den, $p);\n            --$v;\n        }\n\n        Math::GMPz::Rmpz_mul_ui($den_mult, $den_mult, $den);\n        Math::GMPz::Rmpz_mod($den_mult, $den_mult, $m_val);\n    }\n\n    Math::GMPz::Rmpz_invert($temp, $den_mult, $m_val);\n\n    my $ans = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_mul($ans, $num_mult, $temp);\n    Math::GMPz::Rmpz_mod($ans, $ans, $m_val);\n\n    if ($v > 0) {\n        Math::GMPz::Rmpz_ui_pow_ui($temp, $p, $v);\n        Math::GMPz::Rmpz_mul($ans, $ans, $temp);\n        Math::GMPz::Rmpz_mod($ans, $ans, $m_val);\n    }\n\n    return $ans;\n}\n\nsub _is_small_k_binomialmod {\n    my ($n, $k, $m) = @_;\n\n    $n >= 1e6 or return;\n\n    ## say \"Small k check: binomial($n, $k, $m)\";\n\n    if ($m >= 1e7 and $n >= 1e7 and $k <= 1e6) {\n        return 1;\n    }\n\n    my $new_k = Math::Prime::Util::GMP::subint($n, $k);\n\n    if ($new_k > 0 and $new_k < $k) {\n        $k = $new_k;\n    }\n\n    $k <= 1e7 or return;\n\n    my $sqrt_m   = Math::Prime::Util::GMP::sqrtint($m);\n    my $m_over_n = Math::Prime::Util::GMP::divint($m, $n);\n\n    $k < $sqrt_m and $k < $m_over_n;\n}\n\nsub _lucas_theorem {    # p is prime\n    my ($n, $k, $p) = @_;\n\n    my $r = 1;\n    my (@nd, @kd);\n\n    while ($k) {\n        my $np = Math::Prime::Util::GMP::modint($n, $p);\n        my $kp = Math::Prime::Util::GMP::modint($k, $p);\n\n        push @nd, $np;\n        push @kd, $kp;\n\n        if ($kp > $np) { return 0 }\n\n        $n = Math::Prime::Util::GMP::divint($n, $p);\n        $k = Math::Prime::Util::GMP::divint($k, $p);\n    }\n\n    foreach my $i (0 .. $#nd) {\n\n        my $np = $nd[$i];\n        my $kp = $kd[$i];\n        my $rp = Math::Prime::Util::GMP::subint($np, $kp);\n\n        ## say \"Lucas theorem: ($np, $kp, $p)\";\n\n        if (_is_small_k_binomialmod($np, $kp, $p)) {\n            ## say \"Optimization: ($np, $kp, $p)\";\n            my $bin = _small_k_binomialmod($np, $kp, $p);\n            $r = Math::Prime::Util::GMP::mulmod($r, $bin, $p);\n            next;\n        }\n\n        my $x = Math::Prime::Util::GMP::factorialmod($np, $p);\n        my $y = Math::Prime::Util::GMP::factorialmod($kp, $p);\n        my $z = Math::Prime::Util::GMP::factorialmod($rp, $p);\n\n        $y = Math::Prime::Util::GMP::mulmod($y, $z, $p);\n        $x = Math::Prime::Util::GMP::divmod($x, $y, $p) if ($y ne '1');\n        $r = Math::Prime::Util::GMP::mulmod($r, $x, $p);\n    }\n\n    return $r;\n}\n\nsub _modular_binomial {\n    my ($n, $k, $m) = @_;\n\n    # Translation of binomod.gp v1.5 by Max Alekseyev, with some extra optimizations.\n\n    # m == 1\n    if (Math::GMPz::Rmpz_cmp_ui($m, 1) == 0) {\n        return 0;\n    }\n\n    # k < 0\n    if (Math::GMPz::Rmpz_sgn($k) < 0) {\n        $k = $n - $k;\n    }\n\n    # k < n-k < 0\n    if (Math::GMPz::Rmpz_sgn($k) < 0) {\n        return 0;\n    }\n\n    # n < 0\n    if (Math::GMPz::Rmpz_sgn($n) < 0) {\n        my $x = Math::GMPz::Rmpz_even_p($k) ? 1 : -1;\n        $x = Math::Prime::Util::GMP::mulint($x, __SUB__->(-$n + $k - 1, $k, $m));\n        return Math::Prime::Util::GMP::modint($x, $m);\n    }\n\n    # k > n\n    if (Math::GMPz::Rmpz_cmp($k, $n) > 0) {\n        return 0;\n    }\n\n    # k == 0 or k == n\n    if (Math::GMPz::Rmpz_sgn($k) == 0 or Math::GMPz::Rmpz_cmp($k, $n) == 0) {\n        return Math::Prime::Util::GMP::modint(1, $m);\n    }\n\n    # k == 1 or k == n-1\n    if (Math::GMPz::Rmpz_cmp_ui($k, 1) == 0 or $k == $n - 1) {\n        return Math::Prime::Util::GMP::modint($n, $m);\n    }\n\n    # n-k > 0 and n-k < k\n    if (Math::GMPz::Rmpz_cmp($n - $k, $k) < 0) {\n        $k = $n - $k;\n    }\n\n    # k <= 10^4\n    if (Math::GMPz::Rmpz_cmp_ui($k, 1e4) <= 0) {\n        return Math::Prime::Util::GMP::modint(_small_k_binomialmod($n, $k, $m), $m);\n    }\n\n    my @F;\n\n    foreach my $pp (factor_exp(Math::Prime::Util::GMP::absint($m))) {\n        my ($p, $q) = @$pp;\n\n        if ($q == 1) {\n            push @F, [_lucas_theorem($n, $k, $p), $p];\n            next;\n        }\n\n        my $pq = Math::Prime::Util::GMP::powint($p, $q);\n\n        # If $n is smaller than the prime power, we can use the small_k algorithm directly\n        if (Math::Prime::Util::GMP::cmpint($pq, $n) > 0) {\n            push @F, [_small_k_binomialmod($n, $k, $pq, $p), $pq];\n            next;\n        }\n\n        my $d = logint($n, $p) + 1;\n\n        my (@np, @kp);\n\n        do {\n            my $pi = 1;\n            foreach my $i (0 .. $d) {\n                push @np, Math::Prime::Util::GMP::modint(Math::Prime::Util::GMP::divint($n, $pi), $p);\n                push @kp, Math::Prime::Util::GMP::modint(Math::Prime::Util::GMP::divint($k, $pi), $p);\n                $pi = Math::Prime::Util::GMP::mulint($pi, $p);\n            }\n        };\n\n        my @e;\n\n        foreach my $i (0 .. $d) {\n            $e[$i] = ($np[$i] < ($kp[$i] + (($i > 0) ? $e[$i - 1] : 0))) ? 1 : 0;\n        }\n\n        for (my $i = $d - 1 ; $i >= 0 ; --$i) {\n            $e[$i] += $e[$i + 1];\n        }\n\n        if ($e[0] >= $q) {\n            push @F, [0, Math::Prime::Util::GMP::powint($p, $q)];\n            next;\n        }\n\n        my $rq  = $q - $e[0];\n        my $prq = Math::Prime::Util::GMP::powint($p, $rq);\n\n        if (_is_small_k_binomialmod($n, $k, $pq)) {\n            ## say \"Optimization prime power: ($n, $k, $p, $pq)\";\n            my $bin = _small_k_binomialmod($n, $k, $pq);\n            push @F, [$bin, $pq];\n            next;\n        }\n\n        my (@N, @K, @R);\n\n        do {\n            my $pi = 1;\n            my $r  = Math::Prime::Util::GMP::subint($n, $k);\n            foreach my $i (0 .. $d) {\n                push @N, Math::Prime::Util::GMP::modint(Math::Prime::Util::GMP::divint($n, $pi), $prq);\n                push @K, Math::Prime::Util::GMP::modint(Math::Prime::Util::GMP::divint($k, $pi), $prq);\n                push @R, Math::Prime::Util::GMP::modint(Math::Prime::Util::GMP::divint($r, $pi), $prq);\n                $pi = Math::Prime::Util::GMP::mulint($pi, $p);\n            }\n        };\n\n        my @NKR = (\n                   sort { $a->[3] <=> $b->[3] }\n                   map  { [$N[$_], $K[$_], $R[$_], $N[$_] + $K[$_] + $R[$_]] } 0 .. $#N\n                  );\n\n        @N = map { $_->[0] } @NKR;\n        @K = map { $_->[1] } @NKR;\n        @R = map { $_->[2] } @NKR;\n\n        my %acc  = (0 => 1);\n        my $nfac = 1;\n\n        if ($prq < ~0 and $p < $n) {\n            my $count = 0;\n            foreach my $k (1 .. vecmin(vecmax(@N, @K, @R), 1e3)) {\n                if (++$count == $p) {\n                    $count = 0;\n                }\n                else {\n                    $nfac = mulmod($nfac, $k, $prq);\n                }\n                $acc{$k} = $nfac;\n            }\n        }\n\n        my $v = Math::Prime::Util::GMP::powmod($p, $e[0], $pq);\n\n        do {\n            my $from  = 0;\n            my $count = 0;\n            my $res   = 1;\n\n            foreach my $j (0 .. $d) {\n\n                my @pairs;\n                my ($x, $y, $z);\n\n                ($x = $acc{$N[$j]}) // push(@pairs, [\\$x, $N[$j]]);\n                ($y = $acc{$K[$j]}) // push(@pairs, [\\$y, $K[$j]]);\n                ($z = $acc{$R[$j]}) // push(@pairs, [\\$z, $R[$j]]);\n\n                foreach my $pair (sort { $a->[1] <=> $b->[1] } @pairs) {\n                    ## say \"Factorial($pair->[1]) mod $prq with p = $p\";\n                    ${$pair->[0]} = _factorial_without_prime($pair->[1], $p, $prq, \\$from, \\$count, \\$res);\n                }\n\n                $y = Math::Prime::Util::GMP::mulmod($y, $z, $pq);\n                $x = Math::Prime::Util::GMP::divmod($x, $y, $pq) if ($y ne '1');\n                $v = Math::Prime::Util::GMP::mulmod($v, $x, $pq);\n            }\n        };\n\n        if (($p > 2 or $rq < 3) and $rq <= scalar(@e)) {\n            $v = Math::Prime::Util::GMP::mulmod($v, (($e[$rq - 1] % 2 == 0) ? 1 : -1), $pq);\n        }\n\n        push @F, [$v, $pq];\n    }\n\n    Math::Prime::Util::GMP::modint(Math::Prime::Util::GMP::chinese(@F), $m);\n}\n\nsub modular_binomial {\n    my ($n, $k, $m) = @_;\n\n    $n = Math::GMPz->new(\"$n\");\n    $k = Math::GMPz->new(\"$k\");\n    $m = Math::GMPz->new(\"$m\");\n\n    Math::GMPz::Rmpz_sgn($m) || return undef;\n\n    _modular_binomial($n, $k, $m);\n}\n\n#\n## Run some tests\n#\n\nuse Test::More tests => 65;\n\nis(modular_binomial(10, 2, 43), 2);\nis(modular_binomial(10, 8, 43), 2);\n\nis(modular_binomial(10, 2, 24), 21);\nis(modular_binomial(10, 8, 24), 21);\n\nis(modular_binomial(100, 42, -127), binomial(100, 42) % -127);\n\nis(modular_binomial(12,   5,   100000),  792);\nis(modular_binomial(16,   4,   100000),  1820);\nis(modular_binomial(100,  50,  139),     71);\nis(modular_binomial(1000, 10,  1243),    848);\nis(modular_binomial(124,  42,  1234567), 395154);\nis(modular_binomial(1e9,  1e4, 1234567), 833120);\nis(modular_binomial(1e10, 1e5, 1234567), 589372);\n\nis(modular_binomial(1e10,  1e5, 4233330243), 3403056024);\nis(modular_binomial(-1e10, 1e5, 4233330243), 2865877173);\n\nis(modular_binomial(1e10, 1e4, factorial(13)), 1845043200);\nis(modular_binomial(1e10, 1e5, factorial(13)), 1556755200);\nis(modular_binomial(1e10, 1e6, factorial(13)), 5748019200);\n\nis(modular_binomial(-1e10, 1e4, factorial(13)), 4151347200);\nis(modular_binomial(-1e10, 1e5, factorial(13)), 1037836800);\nis(modular_binomial(-1e10, 1e6, factorial(13)), 2075673600);\n\nis(modular_binomial(3, 1, 9),  binomial(3, 1) % 9);\nis(modular_binomial(4, 1, 16), binomial(4, 1) % 16);\n\nis(modular_binomial(1e9,  1e5, 43 * 97 * 503),         585492);\nis(modular_binomial(1e9,  1e6, 5041689707),            15262431);\nis(modular_binomial(1e7,  1e5, 43**2 * 97**3 * 13**4), 1778017500428);\nis(modular_binomial(1e7,  1e5, 42**2 * 97**3 * 13**4), 10015143223176);\nis(modular_binomial(1e9,  1e5, 12345678910),           4517333900);\nis(modular_binomial(1e9,  1e6, 13**2 * 5**6),          2598375);\nis(modular_binomial(1e10, 1e5, 1234567),               589372);\n\nis(modular_binomial(1e5,     1e3, 43),                 binomial(1e5,     1e3) % 43);\nis(modular_binomial(1e5,     1e3, 43 * 97),            binomial(1e5,     1e3) % (43 * 97));\nis(modular_binomial(1e5,     1e3, 43 * 97 * 43),       binomial(1e5,     1e3) % (43 * 97 * 43));\nis(modular_binomial(1e5,     1e3, 43 * 97 * (5**5)),   binomial(1e5,     1e3) % (43 * 97 * (5**5)));\nis(modular_binomial(1e5,     1e3, next_prime(1e4)**2), binomial(1e5,     1e3) % next_prime(1e4)**2);\nis(modular_binomial(1e5,     1e3, next_prime(1e4)),    binomial(1e5,     1e3) % next_prime(1e4));\nis(modular_binomial(1e6,     1e3, next_prime(1e5)),    binomial(1e6,     1e3) % next_prime(1e5));\nis(modular_binomial(1e6,     1e3, next_prime(1e7)),    binomial(1e6,     1e3) % next_prime(1e7));\nis(modular_binomial(1234567, 1e3, factorial(20)),      binomial(1234567, 1e3) % factorial(20));\nis(modular_binomial(1234567, 1e4, factorial(20)),      binomial(1234567, 1e4) % factorial(20));\n\nis(modular_binomial(1e6, 1e3, powint(2, 128) + 1), binomial(1e6, 1e3) % (powint(2, 128) + 1));\nis(modular_binomial(1e6, 1e3, powint(2, 128) - 1), binomial(1e6, 1e3) % (powint(2, 128) - 1));\n\nis(modular_binomial(1e6, 1e4, (powint(2, 128) + 1)**2), binomial(1e6, 1e4) % ((powint(2, 128) + 1)**2));\nis(modular_binomial(1e6, 1e4, (powint(2, 128) - 1)**2), binomial(1e6, 1e4) % ((powint(2, 128) - 1)**2));\nis(modular_binomial(-10, -9,  -10), binomial(-10, -9) % -10);\n\nis(modular_binomial(1e6, 1e3, powint(2, 128) + 1), binomial(1e6, 1e3) % (powint(2, 128) + 1));\nis(modular_binomial(1e6, 1e3, powint(2, 128) - 1), binomial(1e6, 1e3) % (powint(2, 128) - 1));\n\nis(modular_binomial(1e6, 1e4, (powint(2, 128) + 1)**2), binomial(1e6, 1e4) % ((powint(2, 128) + 1)**2));\nis(modular_binomial(1e6, 1e4, (powint(2, 128) - 1)**2), binomial(1e6, 1e4) % ((powint(2, 128) - 1)**2));\n\nis(modular_binomial(1e10, 1e4, powint(prev_prime(powint(2, 64)), 2)), test_binomialmod(1e10, 1e4, powint(prev_prime(powint(2, 64)), 2)));\nis(modular_binomial(1e10, 1e4, next_prime(powint(2, 64))**2),         test_binomialmod(1e10, 1e4, next_prime(powint(2, 64))**2));\n\nis(modular_binomial(1e10, 1e4, prev_prime(powint(2, 64))), test_binomialmod(1e10, 1e4, prev_prime(powint(2, 64))));\nis(modular_binomial(1e10, 1e4, next_prime(powint(2, 64))), test_binomialmod(1e10, 1e4, next_prime(powint(2, 64))));\n\nis(modular_binomial(1e10, 1e3, (powint(2, 127) + 1)), test_binomialmod(1e10, 1e3, powint(2, 127) + 1));\nis(modular_binomial(1e10, 1e3, (powint(2, 127) - 1)), test_binomialmod(1e10, 1e3, powint(2, 127) - 1));\nis(modular_binomial(1e10, 1e5, (powint(2, 127) - 1)), test_binomialmod(1e10, 1e5, powint(2, 127) - 1));\nis(modular_binomial(1e10, 1e5, (powint(2, 127) + 1)), test_binomialmod(1e10, 1e5, powint(2, 127) + 1));\n\nis(modular_binomial(1e10, 1e10 - 1e5, (powint(2, 127) - 1)), test_binomialmod(1e10, 1e5, powint(2, 127) - 1));\nis(modular_binomial(1e10, 1e10 - 1e5, (powint(2, 127) + 1)), test_binomialmod(1e10, 1e5, powint(2, 127) + 1));\nis(modular_binomial(1e10, 1e10 - 1e5, (powint(2, 127) + 1)**2), test_binomialmod(1e10, 1e5, (powint(2, 127) + 1)**2));\n\nis(modular_binomial(1e10, 1e5, (powint(2, 127) - 1)**2), test_binomialmod(1e10, 1e5, (powint(2, 127) - 1)**2));\nis(modular_binomial(1e10, 1e4, (powint(2, 128) - 1)**2), test_binomialmod(1e10, 1e4, (powint(2, 128) - 1)**2));\nis(modular_binomial(1e7,  1e5, (powint(2, 128) - 1)**2), test_binomialmod(1e7,  1e5, (powint(2, 128) - 1)**2));\n\nis(modular_binomial(4294967291 + 1, 1e5, powint(4294967291, 2)), test_binomialmod(4294967291 + 1, 1e5, powint(4294967291, 2)));\nis(modular_binomial(powint(2, 60) - 99, 1e5, prev_prime(1e9)),           test_binomialmod(powint(2, 60) - 99, 1e5, prev_prime(1e9)));\nis(modular_binomial(powint(2, 60) - 99, 1e5, next_prime(powint(2, 64))), test_binomialmod(powint(2, 60) - 99, 1e5, next_prime(powint(2, 64))));\n\nsay(\"binomial(10^10, 10^5) mod 13! = \", modular_binomial(1e10, 1e5, factorial(13)));\n\n__END__\nmy $upto = 10;\nforeach my $n (-$upto .. $upto) {\n    foreach my $k (-$upto .. $upto) {\n        foreach my $m (-$upto .. $upto) {\n            next if ($m == 0);\n            say \"Testing: binomial($n, $k, $m)\";\n            is(modular_binomial($n, $k, $m), binomial($n, $k) % $m);\n        }\n    }\n}\n"
  },
  {
    "path": "Math/modular_binomial_faster_mpz_2.pl",
    "content": "#!/usr/bin/perl\n\n# Fast algorithm for computing the binomial coefficient modulo some integer m.\n# Based on Lucas' Theorem and Granville's generalization:\n#   Andrew Granville, \"The Arithmetic Properties of Binomial Coefficients\",\n#   Proceedings of the Organic Mathematics Workshop, SFU, December 12-14, 1995.\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory 0.74 qw(:all);\nuse Math::Prime::Util::GMP qw();\n\nprime_set_config(bigint => \"Math::BigInt\");\n\n#--------------------------------------------------------------------------\n# Polynomial helpers (coefficients kept mod pk, degree truncated to < e)\n#--------------------------------------------------------------------------\n\n# Multiply two polynomials mod pk, dropping all terms of degree >= e.\nsub _poly_mul {\n    my ($A, $B, $pk, $e) = @_;\n    my @C = (0) x $e;\n    for my $i (0 .. $e - 1) {\n        next unless $A->[$i];\n        for my $j (0 .. $e - 1 - $i) {\n            next unless $B->[$j];\n            $C[$i + $j] = addmod($C[$i + $j], mulmod($A->[$i], $B->[$j], $pk), $pk);\n        }\n    }\n    return \\@C;\n}\n\n# Compute B(x) = A(x + h) mod pk, dropping all terms of degree >= e.\nsub _poly_shift {\n    my ($A, $h_gz, $pk, $e) = @_;\n    my @B = (0) x $e;\n    for my $j (0 .. $e - 1) {\n        next unless $A->[$j];\n        my $h_pow = Math::GMPz->new(1);\n        for my $i (reverse 0 .. $j) {\n            my $term = mulmod(mulmod(binomial($j, $i), $h_pow, $pk), $A->[$j], $pk);\n            $B[$i] = addmod($B[$i], $term, $pk);\n            $h_pow = mulmod($h_pow, $h_gz, $pk) if $i > 0;\n        }\n    }\n    return \\@B;\n}\n\n# Compute P(x, q) = product_{i=0}^{q-1} Poly(x + i) mod pk (degree < e),\n# using divide-and-conquer in q.\nsub _get_P {\n    my ($q_gz, $Poly, $pk, $e) = @_;\n\n    return do { my @r = (0) x $e; $r[0] = 1; \\@r } if Math::GMPz::Rmpz_cmp_ui($q_gz, 0) == 0;\n    return $Poly                                   if Math::GMPz::Rmpz_cmp_ui($q_gz, 1) == 0;\n\n    my $h_gz = Math::GMPz->new(0);\n    Math::GMPz::Rmpz_fdiv_q_2exp($h_gz, $q_gz, 1);    # h = floor(q/2)\n\n    my $P_h  = _get_P($h_gz, $Poly, $pk, $e);\n    my $P_2h = _poly_mul($P_h, _poly_shift($P_h, $h_gz, $pk, $e), $pk, $e);\n\n    # If q is odd (q = 2h+1), multiply by the extra factor Poly(x + 2h)\n    if (Math::GMPz::Rmpz_odd_p($q_gz)) {\n        return _poly_mul($P_2h, _poly_shift($Poly, 2 * $h_gz, $pk, $e), $pk, $e);\n    }\n\n    return $P_2h;\n}\n\n#--------------------------------------------------------------------------\n# Factorial-without-prime helpers\n#--------------------------------------------------------------------------\n\n# Compute n!_p mod pk (= product of 1..n with multiples of p removed),\n# where pk = p^e.  Uses Granville's polynomial method (fast for large n).\nsub _factorial_without_prime_pe {\n    my ($n, $p, $e, $pk) = @_;\n\n    # Small-n shortcut: direct product\n    if (cmpint($n, $p) < 0) {\n        my $res = 1;\n        $res = mulmod($res, $_, $pk) for 1 .. $n;\n        return $res;\n    }\n\n    # Step 1: Build Poly(X) mod pk.\n    # Start from the expansion log(prod_{j=1}^{p-1}(1 + X/j)), collecting\n    # coefficients c[k] of X^k, then scale to Poly[k] = c[k] * (p-1)! * p^k.\n    my @c    = (1, (0) x ($e - 1));\n    my $fact = 1;                     # accumulates (p-1)! mod pk\n\n    for my $j (1 .. subint($p, 1)) {\n        $fact = mulmod($fact, $j, $pk);\n        my $inv = invmod($j, $pk);\n        for my $k (reverse 1 .. $e - 1) {\n            $c[$k] = addmod($c[$k], mulmod($c[$k - 1], $inv, $pk), $pk) if $c[$k - 1];\n        }\n    }\n\n    my @Poly  = (0) x $e;\n    my $p_pow = 1;\n    for my $k (0 .. $e - 1) {\n        $Poly[$k] = mulmod(mulmod($c[$k], $fact, $pk), $p_pow, $pk);\n        $p_pow = mulmod($p_pow, $p, $pk);\n    }\n\n    my $q = divint($n, $p);\n    my $r = modint($n, $p);\n\n    # Step 2: The constant term of P(0, q) gives the main factor.\n    my $q_gz = Math::GMPz::Rmpz_init_set_str(\"$q\", 10);\n    my $res  = _get_P($q_gz, \\@Poly, $pk, $e)->[0];\n\n    # Step 3: Multiply by the tail (pq+1)(pq+2)...(pq+r).\n    if (\"$r\") {\n        my $pq = mulint($q, $p);\n        $res = mulmod($res, addint($pq, $_), $pk) for 1 .. \"$r\";\n    }\n\n    return $res;\n}\n\n# Compute n!_p mod pk, with an incremental cache ($from, $res) that lets\n# successive calls reuse partial products when endpoints are non-decreasing.\nsub _factorial_without_prime {\n    my ($n, $p, $pk, $from, $res) = @_;\n\n    return 1                     if $n <= 1;\n    return factorialmod($n, $pk) if $p > $n;\n    return $$res                 if $$from == $n;\n\n    ($$from, $$res) = (0, 1) if $$from > $n;    # cache unusable; reset\n\n    # Fast path for pk = p^2: Harmonic-number expansion, O(p) cost\n    # instead of the naive O(p^2).\n    if ($p > 2 && cmpint($pk, mulint($p, $p)) == 0) {\n        my $a = divint($n, $p);\n        my $b = modint($n, $p);\n\n        # H_b = sum_{j=1}^{b} 1/j  mod p\n        my $Hb = 0;\n        if ($b > 0) {\n            $Hb = addmod($Hb, invmod($_, $p), $p) for 1 .. $b;\n        }\n\n        my $r = mulmod(powmod(factorialmod(subint($p, 1), $pk), $a, $pk), factorialmod($b, $pk), $pk);\n\n        # Correction term: multiply by (1 + a*p*H_b) mod pk\n        if ($a > 0 && $Hb) {\n            $r = mulmod($r, addmod(1, mulmod(mulmod($a, $p, $pk), $Hb, $pk), $pk), $pk);\n        }\n\n        ($$from, $$res) = ($n, $r);\n        return $r;\n    }\n\n    # Fast path for pk = p^e, e >= 3: Granville polynomial method\n    {\n        my $e = valuation($pk, $p);\n        if ($e >= 3) {\n            my $r = _factorial_without_prime_pe($n, $p, $e, $pk);\n            ($$from, $$res) = ($n, $r);\n            return $r;\n        }\n    }\n\n    # O(n) fallback: direct product (only reached when pk is not a prime power)\n    my $r = $$res;\n    for my $v ($$from + 1 .. $n) {\n        $r = mulmod($r, $v, $pk) if $v % $p;\n    }\n    ($$from, $$res) = ($n, $r);\n    return $r;\n}\n\n# ---------------------------------------------------------------------------\n# Binomial-coefficient helpers\n# ---------------------------------------------------------------------------\n\n# Compute C(n, k) mod m via direct numerator/denominator product.\n# Tracks p-adic valuation of the result to handle the p-part separately.\nsub _small_k_binomialmod {\n    my ($n_val, $k_val, $m_val, $p) = @_;\n\n    $n_val = Math::GMPz::Rmpz_init_set_str(\"$n_val\", 10) unless ref($n_val) eq 'Math::GMPz';\n    $m_val = Math::GMPz::Rmpz_init_set_str(\"$m_val\", 10) unless ref($m_val) eq 'Math::GMPz';\n\n    # For small k or no prime to track, let GMP compute it directly\n    if (!$p or $k_val <= 1e5) {\n        my $bin = Math::GMPz::Rmpz_init();\n        if (Math::GMPz::Rmpz_fits_ulong_p($n_val) && Math::GMPz::Rmpz_cmp_ui($n_val, 1e5) <= 0) {\n            Math::GMPz::Rmpz_bin_uiui($bin, Math::GMPz::Rmpz_get_ui($n_val), $k_val);\n        }\n        else {\n            Math::GMPz::Rmpz_bin_ui($bin, $n_val, $k_val);\n        }\n        Math::GMPz::Rmpz_mod($bin, $bin, $m_val);\n        return $bin;\n    }\n\n    # Track the net p-adic valuation v across numerator and denominator,\n    # keeping running products reduced mod m to avoid huge intermediate values.\n    my $v = 0;\n    state $num_mult = Math::GMPz::Rmpz_init_nobless();\n    state $den_mult = Math::GMPz::Rmpz_init_nobless();\n    state $temp     = Math::GMPz::Rmpz_init_nobless();\n    state $p_z      = Math::GMPz::Rmpz_init_nobless();\n\n    Math::GMPz::Rmpz_set_ui($num_mult, 1);\n    Math::GMPz::Rmpz_set_ui($den_mult, 1);\n    Math::GMPz::Rmpz_set_ui($p_z,      $p);\n\n    for my $i (0 .. $k_val - 1) {\n        Math::GMPz::Rmpz_sub_ui($temp, $n_val, $i);\n\n        if (Math::GMPz::Rmpz_divisible_ui_p($temp, $p)) {\n            $v += Math::GMPz::Rmpz_remove($temp, $temp, $p_z);\n        }\n\n        Math::GMPz::Rmpz_mul($num_mult, $num_mult, $temp);\n        Math::GMPz::Rmpz_mod($num_mult, $num_mult, $m_val);\n\n        my $den = $i + 1;\n        if ($den % $p == 0) {\n            Math::GMPz::Rmpz_set_ui($temp, $den);\n            $v -= Math::GMPz::Rmpz_remove($temp, $temp, $p_z);\n            $den = Math::GMPz::Rmpz_get_ui($temp);\n        }\n\n        Math::GMPz::Rmpz_mul_ui($den_mult, $den_mult, $den);\n        Math::GMPz::Rmpz_mod($den_mult, $den_mult, $m_val);\n    }\n\n    Math::GMPz::Rmpz_invert($temp, $den_mult, $m_val);\n    my $ans = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_mul($ans, $num_mult, $temp);\n    Math::GMPz::Rmpz_mod($ans, $ans, $m_val);\n\n    if ($v > 0) {\n        Math::GMPz::Rmpz_powm_ui($temp, $p_z, $v, $m_val);\n        Math::GMPz::Rmpz_mul($ans, $ans, $temp);\n        Math::GMPz::Rmpz_mod($ans, $ans, $m_val);\n    }\n\n    return $ans;\n}\n\n# Heuristic: is computing C(n, k) mod m via direct product likely cheaper\n# than going through the full Granville machinery?\nsub _is_small_k_binomialmod {\n    my ($n, $k, $m) = @_;\n\n    $n >= 1e6 or return;\n    return 1 if $m >= 1e7 && $n >= 1e7 && $k <= 1e6;\n\n    my $sym_k = subint($n, $k);\n    $k = $sym_k if $sym_k > 0 && $sym_k < $k;\n\n    $k <= 1e7 or return;\n\n    sqrtint($m) > $k\n      && divint($m, $n) > $k;\n}\n\n# Lucas' theorem: C(n, k) mod p for prime p, evaluated digit by digit in base p.\nsub _lucas_theorem {\n    my ($n, $k, $p) = @_;\n    my $r = 1;\n\n    while ($k) {\n        my $np = modint($n, $p);\n        my $kp = modint($k, $p);\n\n        return 0 if $kp > $np;\n\n        if ($kp > 0) {\n            if (_is_small_k_binomialmod($np, $kp, $p)) {\n                $r = mulmod($r, _small_k_binomialmod($np, $kp, $p), $p);\n            }\n            else {\n                my $nf = factorialmod($np, $p);\n                my $df =\n                  mulmod(factorialmod($kp, $p), factorialmod($np - $kp, $p), $p);\n                $r = mulmod($r, ($df ne '1' ? divmod($nf, $df, $p) : $nf), $p);\n            }\n        }\n\n        $n = divint($n, $p);\n        $k = divint($k, $p);\n    }\n\n    return $r;\n}\n\n# ---------------------------------------------------------------------------\n# Core implementation\n# ---------------------------------------------------------------------------\n\nsub _modular_binomial {\n    my ($n, $k, $m) = @_;\n\n    return 0 if Math::GMPz::Rmpz_cmp_ui($m, 1) == 0;\n\n    # Negative k: apply upper-negation identity C(n,k) = C(n, n-k) when k < 0\n    if (Math::GMPz::Rmpz_sgn($k) < 0) {\n        my $tmp = Math::GMPz::Rmpz_init();\n        Math::GMPz::Rmpz_sub($tmp, $n, $k);\n        Math::GMPz::Rmpz_set($k, $tmp);\n    }\n    return 0 if Math::GMPz::Rmpz_sgn($k) < 0;\n\n    # Negative n: C(n,k) = (-1)^k * C(-n+k-1, k)\n    if (Math::GMPz::Rmpz_sgn($n) < 0) {\n        my $sign  = Math::GMPz::Rmpz_even_p($k) ? 1 : -1;\n        my $abs_n = Math::GMPz::Rmpz_init();\n        Math::GMPz::Rmpz_neg($abs_n, $n);\n        Math::GMPz::Rmpz_add($abs_n, $abs_n, $k);\n        Math::GMPz::Rmpz_sub_ui($abs_n, $abs_n, 1);\n        return modint(mulint($sign, __SUB__->($abs_n, $k, $m)), $m);\n    }\n\n    return 0 if Math::GMPz::Rmpz_cmp($k, $n) > 0;\n\n    # Trivial boundary cases\n    return modint(1, $m)\n      if Math::GMPz::Rmpz_sgn($k) == 0 || Math::GMPz::Rmpz_cmp($k, $n) == 0;\n\n    {\n        my $n1 = Math::GMPz::Rmpz_init();\n        Math::GMPz::Rmpz_sub_ui($n1, $n, 1);\n        return modint($n, $m)\n          if Math::GMPz::Rmpz_cmp_ui($k, 1) == 0 || Math::GMPz::Rmpz_cmp($k, $n1) == 0;\n    }\n\n    # Exploit symmetry C(n,k) = C(n, n-k) to keep k <= n/2\n    {\n        my $n_minus_k = Math::GMPz::Rmpz_init();\n        Math::GMPz::Rmpz_sub($n_minus_k, $n, $k);\n        Math::GMPz::Rmpz_set($k, $n_minus_k) if Math::GMPz::Rmpz_cmp($n_minus_k, $k) < 0;\n    }\n\n    return modint(_small_k_binomialmod($n, $k, $m), $m)\n      if Math::GMPz::Rmpz_cmp_ui($k, 1e4) <= 0;\n\n    # General case: factor m into prime powers, solve each via Granville's\n    # method, then combine with CRT.\n    my @F;\n    for my $pp (factor_exp(absint($m))) {\n        my ($p, $q) = @$pp;\n\n        if ($q == 1) {\n            push @F, [_lucas_theorem($n, $k, $p), $p];\n            next;\n        }\n\n        my $pq = powint($p, $q);\n\n        if (cmpint($p, $n) > 0) {\n            push @F, [_small_k_binomialmod($n, $k, $pq, $p), $pq];\n            next;\n        }\n\n        my $d = logint($n, $p) + 1;\n\n        # Base-p digits of n and k (one digit per level, accumulated mod p)\n        my (@np, @kp);\n        {\n            my $pi = 1;\n            for my $i (0 .. $d) {\n                push @np, modint(divint($n, $pi), $p);\n                push @kp, modint(divint($k, $pi), $p);\n                $pi = mulint($pi, $p);\n            }\n        }\n\n        # Kummer's theorem: e[i] = number of carries at position i and above\n        # when adding k and (n-k) in base p.\n        my @e;\n        for my $i (0 .. $d) {\n            $e[$i] = ($np[$i] < ($kp[$i] + ($i > 0 ? $e[$i - 1] : 0))) ? 1 : 0;\n        }\n        for (my $i = $d - 1 ; $i >= 0 ; --$i) {\n            $e[$i] += $e[$i + 1];\n        }\n\n        # If total carries >= q, the result is divisible by p^q, i.e., 0 mod p^q\n        if ($e[0] >= $q) {\n            push @F, [0, $pq];\n            next;\n        }\n\n        my $rq  = $q - $e[0];\n        my $prq = powint($p, $rq);\n\n        if (_is_small_k_binomialmod($n, $k, mulint($p, $q))) {\n            push @F, [_small_k_binomialmod($n, $k, $pq), $pq];\n            next;\n        }\n\n        # Digits of n, k, r = n-k mod p^rq at each level\n        my (@N, @K, @R);\n        {\n            my $pi = 1;\n            my $r  = subint($n, $k);\n            for my $i (0 .. $d) {\n                push @N, modint(divint($n, $pi), $prq);\n                push @K, modint(divint($k, $pi), $prq);\n                push @R, modint(divint($r, $pi), $prq);\n                $pi = mulint($pi, $p);\n            }\n        }\n\n        # Sort triples by N+K+R so _factorial_without_prime's cache is maximally reused\n        {\n            my @idx = sort { ($N[$a] + $K[$a] + $R[$a]) <=> ($N[$b] + $K[$b] + $R[$b]) } 0 .. $#N;\n            @N = @N[@idx];\n            @K = @K[@idx];\n            @R = @R[@idx];\n        }\n\n        # Precompute small factorial-without-p values into a lookup table\n        my %acc  = ('0' => 1);\n        my $nfac = 1;\n        if ($prq < ~0 && $p < $n) {\n            for my $v (1 .. vecmin(vecmax(@N, @K, @R), 1e3)) {\n                $nfac = mulmod($nfac, $v, $prq) if $v % $p;\n                $acc{$v} = $nfac;\n            }\n        }\n\n        my $v = powmod($p, $e[0], $pq);\n\n        {\n            my ($from, $res_cache) = (0, 1);\n\n            for my $j (0 .. $d) {\n                my @pairs;\n                my ($x, $y, $z);\n\n                ($x = $acc{$N[$j]}) // push @pairs, [\\$x, $N[$j]];\n                ($y = $acc{$K[$j]}) // push @pairs, [\\$y, $K[$j]];\n                ($z = $acc{$R[$j]}) // push @pairs, [\\$z, $R[$j]];\n\n                # Process missing entries in ascending order to benefit the cache\n                for my $pair (sort { $a->[1] <=> $b->[1] } @pairs) {\n                    ${$pair->[0]} = _factorial_without_prime($pair->[1], $p, $prq, \\$from, \\$res_cache);\n                }\n\n                $y = mulmod($y, $z, $pq);\n                $x = divmod($x, $y, $pq) if $y ne '1';\n                $v = mulmod($v, $x, $pq);\n            }\n        }\n\n        # Wilson's theorem sign correction\n        if (($p > 2 || $rq < 3) && $rq <= scalar(@e)) {\n            $v = mulmod($v, $e[$rq - 1] % 2 == 0 ? 1 : -1, $pq);\n        }\n\n        push @F, [$v, $pq];\n    }\n\n    Math::Prime::Util::GMP::modint(Math::Prime::Util::GMP::chinese(@F), $m);\n}\n\n# ---------------------------------------------------------------------------\n# Public interface\n# ---------------------------------------------------------------------------\n\nsub modular_binomial {\n    my ($n, $k, $m) = @_;\n\n    $n = Math::GMPz->new(\"$n\");\n    $k = Math::GMPz->new(\"$k\");\n    $m = Math::GMPz->new(\"$m\");\n\n    return undef unless Math::GMPz::Rmpz_sgn($m);\n\n    _modular_binomial($n, $k, $m);\n}\n\nuse Math::Sidef qw();\n\nsub test_binomialmod($n, $k, $m) {\n    Math::Sidef::binomialmod($n, $k, $m);\n}\n\n#\n## Run some tests\n#\n\nuse Test::More tests => 103;\n\nfor my $e (1 .. 5) {\n    my $n = powint(2,                33) + int rand 1234;\n    my $k = powint(2,                32) - int rand 1234;\n    my $m = powint(2 + int rand 100, $e);\n    say \"binomialmod($n,$k,$m) = \", modular_binomial($n, $k, $m);\n    is(modular_binomial($n, $k, $m), test_binomialmod($n, $k, $m));\n}\n\nis(modular_binomial(8589934703, 4294966460, 4182119424),          4133348352);\nis(modular_binomial(8589934823, 4294966769, 52521875),            26643750);\nis(modular_binomial(8589935272, 429496,     \"97656250000000000\"), \"57900778336640000\");\nis(modular_binomial(8589935272, 4294965,    \"97656250000000000\"), \"96886205280000000\");\nis(modular_binomial(8589935272, 4294966820, \"97656250000000000\"), \"55077260000000000\");\nis(modular_binomial(8589935272, 42949658,   \"97656250000000000\"), \"46773145040000000\");\n\nis(modular_binomial(10, 2, 43), 2);\nis(modular_binomial(10, 8, 43), 2);\n\nis(modular_binomial(10, 2, 24), 21);\nis(modular_binomial(10, 8, 24), 21);\n\nis(modular_binomial(100, 42, -127), binomial(100, 42) % -127);\n\nis(modular_binomial(12,   5,   100000),  792);\nis(modular_binomial(16,   4,   100000),  1820);\nis(modular_binomial(100,  50,  139),     71);\nis(modular_binomial(1000, 10,  1243),    848);\nis(modular_binomial(124,  42,  1234567), 395154);\nis(modular_binomial(1e9,  1e4, 1234567), 833120);\nis(modular_binomial(1e10, 1e5, 1234567), 589372);\n\nis(modular_binomial(1e10,  1e5, 4233330243), 3403056024);\nis(modular_binomial(-1e10, 1e5, 4233330243), 2865877173);\n\nis(modular_binomial(1e10, 1e4, factorial(13)), 1845043200);\nis(modular_binomial(1e10, 1e5, factorial(13)), 1556755200);\nis(modular_binomial(1e10, 1e6, factorial(13)), 5748019200);\n\nis(modular_binomial(-1e10, 1e4, factorial(13)), 4151347200);\nis(modular_binomial(-1e10, 1e5, factorial(13)), 1037836800);\nis(modular_binomial(-1e10, 1e6, factorial(13)), 2075673600);\n\nis(modular_binomial(3, 1, 9),  binomial(3, 1) % 9);\nis(modular_binomial(4, 1, 16), binomial(4, 1) % 16);\n\nis(modular_binomial(1e9,  1e5, 43 * 97 * 503),         585492);\nis(modular_binomial(1e9,  1e6, 5041689707),            15262431);\nis(modular_binomial(1e7,  1e5, 43**2 * 97**3 * 13**4), 1778017500428);\nis(modular_binomial(1e7,  1e5, 42**2 * 97**3 * 13**4), 10015143223176);\nis(modular_binomial(1e9,  1e5, 12345678910),           4517333900);\nis(modular_binomial(1e9,  1e6, 13**2 * 5**6),          2598375);\nis(modular_binomial(1e10, 1e5, 1234567),               589372);\n\nis(modular_binomial(1e5,     1e3, 43),                 binomial(1e5,     1e3) % 43);\nis(modular_binomial(1e5,     1e3, 43 * 97),            binomial(1e5,     1e3) % (43 * 97));\nis(modular_binomial(1e5,     1e3, 43 * 97 * 43),       binomial(1e5,     1e3) % (43 * 97 * 43));\nis(modular_binomial(1e5,     1e3, 43 * 97 * (5**5)),   binomial(1e5,     1e3) % (43 * 97 * (5**5)));\nis(modular_binomial(1e5,     1e3, next_prime(1e4)**2), binomial(1e5,     1e3) % next_prime(1e4)**2);\nis(modular_binomial(1e5,     1e3, next_prime(1e4)),    binomial(1e5,     1e3) % next_prime(1e4));\nis(modular_binomial(1e6,     1e3, next_prime(1e5)),    binomial(1e6,     1e3) % next_prime(1e5));\nis(modular_binomial(1e6,     1e3, next_prime(1e7)),    binomial(1e6,     1e3) % next_prime(1e7));\nis(modular_binomial(1234567, 1e3, factorial(20)),      binomial(1234567, 1e3) % factorial(20));\nis(modular_binomial(1234567, 1e4, factorial(20)),      binomial(1234567, 1e4) % factorial(20));\n\nis(modular_binomial(1e6, 1e3, powint(2, 128) + 1), binomial(1e6, 1e3) % (powint(2, 128) + 1));\nis(modular_binomial(1e6, 1e3, powint(2, 128) - 1), binomial(1e6, 1e3) % (powint(2, 128) - 1));\n\nis(modular_binomial(1e6, 1e4, (powint(2, 128) + 1)**2), binomial(1e6, 1e4) % ((powint(2, 128) + 1)**2));\nis(modular_binomial(1e6, 1e4, (powint(2, 128) - 1)**2), binomial(1e6, 1e4) % ((powint(2, 128) - 1)**2));\nis(modular_binomial(-10, -9,  -10), binomial(-10, -9) % -10);\n\nis(modular_binomial(1e6, 1e3, powint(2, 128) + 1), binomial(1e6, 1e3) % (powint(2, 128) + 1));\nis(modular_binomial(1e6, 1e3, powint(2, 128) - 1), binomial(1e6, 1e3) % (powint(2, 128) - 1));\n\nis(modular_binomial(1e6, 1e4, (powint(2, 128) + 1)**2), binomial(1e6, 1e4) % ((powint(2, 128) + 1)**2));\nis(modular_binomial(1e6, 1e4, (powint(2, 128) - 1)**2), binomial(1e6, 1e4) % ((powint(2, 128) - 1)**2));\n\nis(modular_binomial(1e10, 1e4, powint(prev_prime(powint(2, 64)), 2)), test_binomialmod(1e10, 1e4, powint(prev_prime(powint(2, 64)), 2)));\nis(modular_binomial(1e10, 1e4, next_prime(powint(2, 64))**2),         test_binomialmod(1e10, 1e4, next_prime(powint(2, 64))**2));\n\nis(modular_binomial(1e10, 1e4, prev_prime(powint(2, 64))), test_binomialmod(1e10, 1e4, prev_prime(powint(2, 64))));\nis(modular_binomial(1e10, 1e4, next_prime(powint(2, 64))), test_binomialmod(1e10, 1e4, next_prime(powint(2, 64))));\n\nis(modular_binomial(1e10, 1e3, (powint(2, 127) + 1)), test_binomialmod(1e10, 1e3, powint(2, 127) + 1));\nis(modular_binomial(1e10, 1e3, (powint(2, 127) - 1)), test_binomialmod(1e10, 1e3, powint(2, 127) - 1));\nis(modular_binomial(1e10, 1e5, (powint(2, 127) - 1)), test_binomialmod(1e10, 1e5, powint(2, 127) - 1));\nis(modular_binomial(1e10, 1e5, (powint(2, 127) + 1)), test_binomialmod(1e10, 1e5, powint(2, 127) + 1));\n\nis(modular_binomial(1e10, 1e10 - 1e5, (powint(2, 127) - 1)), test_binomialmod(1e10, 1e5, powint(2, 127) - 1));\nis(modular_binomial(1e10, 1e10 - 1e5, (powint(2, 127) + 1)), test_binomialmod(1e10, 1e5, powint(2, 127) + 1));\nis(modular_binomial(1e10, 1e10 - 1e5, (powint(2, 127) + 1)**2), test_binomialmod(1e10, 1e5, (powint(2, 127) + 1)**2));\n\nis(modular_binomial(1e10, 1e5, (powint(2, 127) - 1)**2), test_binomialmod(1e10, 1e5, (powint(2, 127) - 1)**2));\nis(modular_binomial(1e10, 1e4, (powint(2, 128) - 1)**2), test_binomialmod(1e10, 1e4, (powint(2, 128) - 1)**2));\nis(modular_binomial(1e7,  1e5, (powint(2, 128) - 1)**2), test_binomialmod(1e7,  1e5, (powint(2, 128) - 1)**2));\n\nis(modular_binomial(4294967291 + 1, 1e5, powint(4294967291, 2)), test_binomialmod(4294967291 + 1, 1e5, powint(4294967291, 2)));\nis(modular_binomial(powint(2, 60) - 99, 1e5, prev_prime(1e9)),           test_binomialmod(powint(2, 60) - 99, 1e5, prev_prime(1e9)));\nis(modular_binomial(powint(2, 60) - 99, 1e5, next_prime(powint(2, 64))), test_binomialmod(powint(2, 60) - 99, 1e5, next_prime(powint(2, 64))));\n\nis(binomialmod(0, 0, 7), 1);\nis(modular_binomial(0,         1,        7),          0);\nis(modular_binomial(0,         2,        7),          0);\nis(modular_binomial(3,         0,        7),          1);\nis(modular_binomial(7,         5,        11),         10);\nis(modular_binomial(950,       100,      123456),     24942);\nis(modular_binomial(950,       100,      7),          2);\nis(modular_binomial(8100,      4000,     1155),       924);\nis(modular_binomial(950,       100,      1000000007), 640644226);\nis(modular_binomial(189,       34,       877),        81);\nis(modular_binomial(189,       34,       253009),     47560);\nis(modular_binomial(189,       34,       36481),      14169);\nis(modular_binomial(1900,      17,       41),         0);\nis(modular_binomial(5000,      654,      101223721),  59171352);\nis(modular_binomial(-112,      5,        351),        313);\nis(modular_binomial(-189,      34,       877),        141);\nis(modular_binomial(-23,       -29,      377),        117);\nis(modular_binomial(189,       -34,      877),        0);\nis(modular_binomial(100000000, 87654321, 1005973),    937361);\nis(modular_binomial(100000000, 7654321,  1299709),    582708);\nis(modular_binomial(100000000, 7654321,  12345678),   4152168);\nis(modular_binomial(100000,    7654,     32768),      12288);\nis(modular_binomial(100000,    7654,     196608),     110592);\nis(modular_binomial(100000,    7654,     101223721),  5918452);\nis(modular_binomial(100000000, 7654321,  32768),      24576);\nis(modular_binomial(100000000, 7654321,  196608),     122880);\nis(modular_binomial(100000000, 7654321,  101223721),  5463123);\n\nsay(\"binomial(10^10, 10^5) mod 13! = \", modular_binomial(1e10, 1e5, factorial(13)));\n"
  },
  {
    "path": "Math/modular_binomial_ntheory.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 29 September 2017\n# https://github.com/trizen\n\n# Compute `binomial(n, k) % m`, using the `factorialmod(n, m)` function from ntheory.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(divmod factorialmod);\n\nsub modular_binomial {\n    my ($n, $k, $m) = @_;\n    divmod(divmod(factorialmod($n, $m), factorialmod($k, $m), $m), factorialmod($n - $k, $m), $m);\n}\n\nsay modular_binomial(100, 50, 139);        #=> 71\nsay modular_binomial(124, 42, 1234567);    #=> 395154\n"
  },
  {
    "path": "Math/modular_binomial_small_k.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 29 September 2017\n# Website: https://github.com/trizen\n\n# A decently efficient algorithm for computing `binomial(n, k) mod m`, where `k` is small (<~ 10^6).\n\n# Implemented using the identity:\n#    binomial(n, k) = Product_{r = n-k+1..n}(r) / k!\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse List::Util qw(uniq);\nuse experimental qw(signatures);\n\nsub factorial_power ($n, $p) {\n    ($n - vecsum(todigits($n, $p))) / ($p - 1);\n}\n\nsub modular_binomial ($n, $k, $m) {\n\n    my %kp;\n    my $prod = 1;\n\n    forfactored {\n\n        my $r       = $_;\n        my @factors = uniq(@_);\n\n        foreach my $p (@factors) {\n\n            if ($p <= $k) {\n                next if ((my $t = ($kp{$p} //= factorial_power($k, $p))) == 0);\n\n                my $v = valuation($r, $p);\n\n                if ($v >= $t) {\n                    $v = $t;\n                    $kp{$p} = 0;\n                }\n                else {\n                    $kp{$p} -= $v;\n                }\n\n                last if (($r /= $p**$v) <= 1);\n            }\n            else {\n                last;\n            }\n        }\n\n        $prod = mulmod($prod, $r, $m);\n    } $n - $k + 1, $n;\n\n    return $prod;\n}\n\nsay modular_binomial(12,   5,   100000);     #=> 792\nsay modular_binomial(16,   4,   100000);     #=> 1820\nsay modular_binomial(100,  50,  139);        #=> 71\nsay modular_binomial(1000, 10,  1243);       #=> 848\nsay modular_binomial(124,  42,  1234567);    #=> 395154\nsay modular_binomial(1e9,  1e4, 1234567);    #=> 833120\nsay modular_binomial(1e10, 1e5, 1234567);    #=> 589372\n"
  },
  {
    "path": "Math/modular_binomial_small_k_faster.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 27 April 2022\n# https://github.com/trizen\n\n# A decently efficient algorithm for computing `binomial(n, k) mod m`, where `k` is small (<~ 10^6).\n\n# Implemented using the identity:\n#    binomial(n, k) = Product_{r = n-k+1..n}(r) / k!\n\n# And also using the identitiy:\n#   binomial(n, k) = Prod_{j=0..k-1} (n-j)/(j+1)\n\n# See also:\n#   https://en.wikipedia.org/wiki/Lucas%27s_theorem\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory      qw(:all);\nuse List::Util   qw(uniq);\nuse experimental qw(signatures);\n\nsub factorial_power ($n, $p) {\n    divint($n - vecsum(todigits($n, $p)), $p - 1);\n}\n\nsub modular_binomial_small_k ($n, $k, $m) {\n\n    my %kp;\n    my $prod = 1;\n\n    if ($n - $k < $k) {\n        $k = $n - $k;\n    }\n\n    if (is_prime($m)) {\n\n        foreach my $j (0 .. $k - 1) {\n            $prod = mulmod($prod, $n - $j, $m);\n            $prod = divmod($prod, $j + 1, $m);\n        }\n\n        return $prod;\n    }\n\n    forfactored {\n\n        my $r       = $_;\n        my @factors = uniq(@_);\n\n        foreach my $p (@factors) {\n\n            if ($p <= $k) {\n                next if ((my $t = ($kp{$p} //= factorial_power($k, $p))) == 0);\n\n                my $v = valuation($r, $p);\n\n                if ($v >= $t) {\n                    $v = $t;\n                    $kp{$p} = 0;\n                }\n                else {\n                    $kp{$p} -= $v;\n                }\n\n                $r = divint($r, powint($p, $v));\n                last if ($r == 1);\n            }\n            else {\n                last;\n            }\n        }\n\n        $prod = mulmod($prod, $r, $m);\n    } $n - $k + 1, $n;\n\n    return $prod;\n}\n\nsub lucas_theorem ($n, $k, $p) {\n\n    if ($n < $k) {\n        return 0;\n    }\n\n    my $res = 1;\n\n    while ($k > 0) {\n        my ($Nr, $Kr) = (modint($n, $p), modint($k, $p));\n\n        if ($Nr < $Kr) {\n            return 0;\n        }\n\n        ($n, $k) = (divint($n, $p), divint($k, $p));\n        $res = mulmod($res, modular_binomial_small_k($Nr, $Kr, $p), $p);\n    }\n\n    return $res;\n}\n\nsub modular_binomial ($n, $k, $m) {\n\n    if ($m == 0) {\n        return undef;\n    }\n\n    if ($m == 1) {\n        return 0;\n    }\n\n    if ($k < 0) {\n        $k = subint($n, $k);\n    }\n\n    if ($k < 0) {\n        return 0;\n    }\n\n    if ($n < 0) {\n        return modint(mulint(powint(-1, $k), __SUB__->(subint($k, $n) - 1, $k, $m)), $m);\n    }\n\n    if ($k > $n) {\n        return 0;\n    }\n\n    if ($k == 0 or $k == $n) {\n        return modint(1, $m);\n    }\n\n    if ($n - $k < $k) {\n        $k = $n - $k;\n    }\n\n    is_square_free(absint($m))\n      || return modint(modular_binomial_small_k($n, $k, absint($m)), $m);\n\n    my @congruences;\n\n    foreach my $pp (factor_exp(absint($m))) {\n        my ($p, $e) = @$pp;\n\n        my $pk = powint($p, $e);\n\n        if ($e == 1) {\n            push @congruences, [lucas_theorem($n, $k, $p), $p];\n        }\n        else {\n            push @congruences, [modular_binomial_small_k($n, $k, $pk), $pk];\n        }\n    }\n\n    modint(chinese(@congruences), $m);\n}\n\nsay modular_binomial(12,   5,   100000);       #=> 792\nsay modular_binomial(16,   4,   100000);       #=> 1820\nsay modular_binomial(100,  50,  139);          #=> 71\nsay modular_binomial(1000, 10,  1243);         #=> 848\nsay modular_binomial(124,  42,  1234567);      #=> 395154\nsay modular_binomial(1e9,  1e4, 1234567);      #=> 833120\nsay modular_binomial(1e10, 1e5, 1234567);      #=> 589372\nsay modular_binomial(1e10, 1e6, 1234567);      #=> 456887\nsay modular_binomial(1e9,  1e4, 123456791);    #=> 106271399\nsay modular_binomial(1e10, 1e5, 123456791);    #=> 20609240\n\n__END__\nuse Test::More tests => 8820;\n\nmy $upto = 10;\nforeach my $n (-$upto .. $upto) {\n    foreach my $k (-$upto .. $upto) {\n        foreach my $m (-$upto .. $upto) {\n            next if ($m == 0);\n            say \"Testing: binomial($n, $k, $m)\";\n            is(modular_binomial($n, $k, $m), binomial($n, $k) % $m);\n        }\n    }\n}\n"
  },
  {
    "path": "Math/modular_cyclotomic_polynomial.pl",
    "content": "#!/usr/bin/perl\r\n\r\n# Author: Trizen\r\n# Date: 08 May 2022\r\n# https://github.com/trizen\r\n\r\n# Efficiently compute the n-th Cyclotomic polynomial modulo m, evaluated at x.\r\n\r\nuse 5.020;\r\nuse strict;\r\nuse warnings;\r\n\r\nuse Math::GMPz;\r\nuse ntheory qw(:all);\r\nuse experimental qw(signatures);\r\n\r\nsub cyclotomicmod ($n, $x, $m) {\r\n\r\n    $n = Math::GMPz->new(\"$n\");\r\n    $x = Math::GMPz->new(\"$x\");\r\n    $m = Math::GMPz->new(\"$m\");\r\n\r\n    Math::GMPz::Rmpz_sgn($m) || return;\r\n\r\n    # n must be >= 0\r\n    (Math::GMPz::Rmpz_sgn($n) || return 0) > 0\r\n      or return;\r\n\r\n    return 0 if (Math::GMPz::Rmpz_cmp_ui($m, 1) == 0);\r\n\r\n    return (($x - 1) % $m) if (Math::GMPz::Rmpz_cmp_ui($n, 1) == 0);\r\n    return (($x + 1) % $m) if (Math::GMPz::Rmpz_cmp_ui($n, 2) == 0);\r\n\r\n    # Special case for x = 1: cyclotomic(n, 1) is A020500.\r\n    if (Math::GMPz::Rmpz_cmp_ui($x, 1) == 0) {\r\n        my $k = is_prime_power($n) || return 1;\r\n        my $p = rootint($n, $k);\r\n        return modint($p, $m);\r\n    }\r\n\r\n    # Special case for x = -1: cyclotomic(n, -1) is A020513.\r\n    if (Math::GMPz::Rmpz_cmp_si($x, -1) == 0) {\r\n        Math::GMPz::Rmpz_even_p($n) || return 1;\r\n        my $o = $n >> 1;\r\n        my $k = is_prime_power($o) || return 1;\r\n        my $p = rootint($o, $k);\r\n        return modint($p, $m);\r\n    }\r\n\r\n    my @factor_exp = factor_exp($n);\r\n\r\n    # Generate the squarefree divisors of n, along\r\n    # with the number of prime factors of each divisor\r\n    my @sd;\r\n    foreach my $pe (@factor_exp) {\r\n        my ($p) = @$pe;\r\n\r\n        $p =\r\n          ($p < ~0)\r\n          ? Math::GMPz::Rmpz_init_set_ui($p)\r\n          : Math::GMPz::Rmpz_init_set_str(\"$p\", 10);\r\n\r\n        push @sd, map { [$_->[0] * $p, $_->[1] + 1] } @sd;\r\n        push @sd, [$p, 1];\r\n    }\r\n\r\n    push @sd, [Math::GMPz::Rmpz_init_set_ui(1), 0];\r\n\r\n    my $prod = Math::GMPz::Rmpz_init_set_ui(1);\r\n\r\n    foreach my $pair (@sd) {\r\n        my ($d, $c) = @$pair;\r\n\r\n        my $base = Math::GMPz::Rmpz_init();\r\n        Math::GMPz::Rmpz_divexact($base, $n, $d);\r\n        Math::GMPz::Rmpz_powm($base, $x, $base, $m);    # x^(n/d) mod m\r\n        Math::GMPz::Rmpz_sub_ui($base, $base, 1);\r\n\r\n        if ($c % 2 == 1) {\r\n            Math::GMPz::Rmpz_invert($base, $base, $m) || return;\r\n        }\r\n\r\n        Math::GMPz::Rmpz_mul($prod, $prod, $base);\r\n        Math::GMPz::Rmpz_mod($prod, $prod, $m);\r\n    }\r\n\r\n    return $prod;\r\n}\r\n\r\nsay cyclotomicmod(factorial(30), 5040,                        Math::GMPz->new(2)**128 + 1);\r\nsay cyclotomicmod(factorial(20), Math::GMPz->new(2)**127 - 1, Math::GMPz->new(2)**128 + 1);\r\n\r\n__END__\r\n40675970320518606495224484019728682382\r\n194349103384996189019641296094415725728\r\n"
  },
  {
    "path": "Math/modular_factorial.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 21 August 2016\n# Edit: 15 April 2026\n# Website: https://github.com/trizen\n\n# An efficient algorithm for computing factorial of a large number, modulo a larger number.\n\nuse 5.036;\nuse ntheory 0.74 qw(\n    invmod powmod forprimes random_prime\n    todigits vecsum divint mulmod addmod vecprod\n);\n\nsub factorial_power ($n, $p) {\n    divint($n - vecsum(todigits($n, $p)), $p - 1);\n}\n\n# This algorithm uses powers of primes to efficiently\n# compute `n! mod k`. It works correctly in all cases.\n\nsub facmod2 ($n, $mod) {\n\n    my $p = 0;\n    my $f = 1;\n\n    forprimes {\n        if ($p == 1) {\n            $f = mulmod($f, $_, $mod);\n        }\n        else {\n            $p = factorial_power($n, $_);\n            $f = mulmod($f, powmod($_, $p, $mod), $mod);\n        }\n    } $n;\n\n    return $f;\n}\n\n# This algorithm is fast and correct only when `mod`\n# is larger than `n`, but no more than twice as large.\n\n# Algorithm from:\n#   https://stackoverflow.com/questions/9727962/fast-way-to-calculate-n-mod-m-where-m-is-prime\n\nsub facmod1 ($n, $mod) {\n\n    if ($n <= divint($mod, 2) or $mod <= $n) {\n        return facmod2($n, $mod);\n    }\n\n    my $f = 1;\n    foreach my $k ($n + 1 .. $mod - 1) {\n        $f = mulmod($f, $k, $mod);\n    }\n\n    addmod(mulmod(-1, (invmod($f, $mod) // 0), $mod), $mod, $mod);\n}\n\nmy $n = 1000000;\nmy $m = vecprod(503, 503, 863, 1000000007);\nsay facmod2($n, $m);           #=> 51017729998226472\n\nforeach my $n (100000 .. 100000 + 10) {\n    my $p = random_prime($n, $n * 2 - 1);\n    my $f1 = facmod1($n, $p);\n    my $f2 = facmod2($n, $p);\n\n    if ($f1 != $f2) {\n        warn \"ERROR: returned values ($f1, $f2) don't agree for ($n, $p)\\n\";\n    }\n\n    printf(\"%5d! mod %5d = %5d\\n\", $n, $p, $f1);\n}\n\n__END__\n100000! mod 124783 = 118955\n100001! mod 169987 = 155308\n100002! mod 188431 = 22741\n100003! mod 100747 = 92927\n100004! mod 164251 = 42227\n100005! mod 117191 = 65606\n100006! mod 121327 = 119432\n100007! mod 172259 = 152151\n100008! mod 176927 = 39009\n100009! mod 135571 = 28311\n100010! mod 164093 = 36407\n"
  },
  {
    "path": "Math/modular_factorial_crt.pl",
    "content": "#!/usr/bin/perl\n\n# A simple O(n) algorithm for computing n! mod m, by factoring m and combining with CRT.\n\nuse 5.036;\nuse ntheory 0.74 qw(\n    factor_exp chinese vecsum todigits\n    powint divint mulmod forprimes powmod vecprod\n);\n\n# Legendre's Formula: Computes the exponent of highest power of p dividing n!\n# Runs in O(log_p(n)) time.\nsub _legendre_valuation ($n, $p) {\n    divint($n - vecsum(todigits($n, $p)), $p - 1);\n}\n\nsub _facmod ($n, $mod) {\n\n    my $p = 0;\n    my $f = 1;\n\n    forprimes {\n        if ($p == 1) {\n            $f = mulmod($f, $_, $mod);\n        }\n        else {\n            $p = _legendre_valuation($n, $_);\n            $f = mulmod($f, powmod($_, $p, $mod), $mod);\n        }\n    } $n;\n\n    return $f;\n}\n\nsub factorialmod_crt ($n, $m) {\n\n    # Trivial base cases\n    if ($n >= $m or $m == 1) {\n        return 0;\n    }\n    if ($n <= 1) {\n        return 1;\n    }\n\n    # Factor m into prime powers [ [p1, e1], [p2, e2], ... ]\n    my @factors = factor_exp($m);\n\n    my @residues;\n    for my $factor_ref (@factors) {\n        my ($p, $e) = @$factor_ref;\n\n        # Calculate p^e\n        my $pe = powint($p, $e);\n\n        # Get the power of p dividing n!\n        my $valuation = _legendre_valuation($n, $p);\n\n        # If the power of p in n! is >= e, then n! is divisible by p^e.\n        # This is where we save O(n) computations!\n        if ($valuation >= $e) {\n            push @residues, [0, $pe];\n            next;\n        }\n\n        # If we reach here, n! is NOT perfectly divisible by p^e.\n        # This means n is quite small relative to p^e. We compute it directly.\n        my $res = _facmod($n, $pe);\n\n        push @residues, [$res, $pe];\n    }\n\n    # Recombine using Chinese Remainder Theorem\n    chinese(@residues);\n}\n\n# --- Example Usage ---\n\nmy $n = 1000000;\nmy $m = vecprod(503, 503, 863, 1000000007);\nsay factorialmod_crt($n, $m);           #=> 51017729998226472\n"
  },
  {
    "path": "Math/modular_factorial_crt_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# A simple O(n) algorithm for computing n! mod m, by factoring m and combining with CRT.\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory qw(\n    factor_exp chinese forprimes\n    divint vecsum todigits vecprod\n);\n\n# Legendre's Formula: Computes the exponent of highest power of p dividing n!\n# Runs in O(log_p(n)) time.\nsub _legendre_valuation ($n, $p) {\n    divint($n - vecsum(todigits($n, $p)), $p - 1);\n}\n\nsub _facmod ($n, $mod) {\n\n    my $p = 0;\n    my $f = Math::GMPz::Rmpz_init_set_ui(1);\n\n    state $t = Math::GMPz::Rmpz_init_nobless();\n\n    forprimes {\n        if ($p == 1) {\n            Math::GMPz::Rmpz_mul_ui($f, $f, $_);\n            Math::GMPz::Rmpz_mod($f, $f, $mod);\n        }\n        else {\n            $p = _legendre_valuation($n, $_);\n            Math::GMPz::Rmpz_set_ui($t, $_);\n            Math::GMPz::Rmpz_powm_ui($t, $t, $p, $mod);\n            Math::GMPz::Rmpz_mul($f, $f, $t);\n            Math::GMPz::Rmpz_mod($f, $f, $mod);\n        }\n    } $n;\n\n    return $f;\n}\n\nsub factorialmod_crt ($n_scalar, $m_scalar) {\n\n    my $n = Math::GMPz->new($n_scalar);\n    my $m = Math::GMPz->new($m_scalar);\n\n    # Trivial base cases\n    if (Math::GMPz::Rmpz_cmp($n, $m) >= 0 or Math::GMPz::Rmpz_cmp_ui($m, 1) == 0) {\n        return Math::GMPz->new(0);\n    }\n    if (Math::GMPz::Rmpz_cmp_ui($n, 1) <= 0) {\n        return Math::GMPz->new(1);\n    }\n\n    # Factor m into prime powers [ [p1, e1], [p2, e2], ... ]\n    my @factors = factor_exp($m_scalar);\n\n    my $p_z  = Math::GMPz::Rmpz_init();\n    my $pe_z = Math::GMPz::Rmpz_init();\n\n    my @residues;\n    for my $factor_ref (@factors) {\n        my ($p, $e) = @$factor_ref;\n\n        # Calculate p^e\n        Math::GMPz::Rmpz_set_str($p_z, $p, 10);\n        Math::GMPz::Rmpz_pow_ui($pe_z, $p_z, $e);\n\n        # Get the power of p dividing n!\n        my $valuation = _legendre_valuation($n_scalar, $p);\n\n        # If the power of p in n! is >= e, then n! is divisible by p^e.\n        # This is where we save O(n) computations!\n        if ($valuation >= $e) {\n            push @residues, [0, Math::GMPz::Rmpz_get_str($pe_z, 10)];\n            next;\n        }\n\n        # If we reach here, n! is NOT perfectly divisible by p^e.\n        # This means n is quite small relative to p^e. We compute it directly.\n        my $res = _facmod(Math::GMPz::Rmpz_get_ui($n), $pe_z);\n\n        push @residues, [\n            Math::GMPz::Rmpz_get_str($res, 10),\n            Math::GMPz::Rmpz_get_str($pe_z, 10)\n        ];\n    }\n\n    # Recombine using Chinese Remainder Theorem\n    Math::GMPz->new(chinese(@residues));\n}\n\n# --- Example Usage ---\n\nmy $n = 1000000;\nmy $m = vecprod(503, 503, 863, 1000000007);\nsay factorialmod_crt($n, $m);           #=> 51017729998226472\n"
  },
  {
    "path": "Math/modular_fibonacci.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 21 August 2016\n# Edit: 30 September 2017\n# https://github.com/trizen\n\n# An efficient algorithm for computing large Fibonacci numbers, modulo some n.\n\n# Algorithm from:\n#   https://codeforces.com/blog/entry/14516\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(mulmod addmod);\nuse experimental qw(signatures);\n\nsub fibmod($n, $mod, $cache={}) {\n\n    $n <= 1 && return $n;\n\n    sub ($n) {\n\n        $n <= 1 && return 1;\n\n        if (exists($cache->{$n})) {\n            return $cache->{$n};\n        }\n\n        my $k = $n >> 1;\n\n#<<<\n        $cache->{$n} = (\n            ($n % 2 == 0)\n                ? addmod(mulmod(__SUB__->($k), __SUB__->($k    ), $mod), mulmod(__SUB__->($k - 1), __SUB__->($k - 1), $mod), $mod)\n                : addmod(mulmod(__SUB__->($k), __SUB__->($k + 1), $mod), mulmod(__SUB__->($k - 1), __SUB__->($k    ), $mod), $mod)\n        );\n#>>>\n\n    }->($n - 1);\n}\n\nsay fibmod(329468, 10**10, {});     # 352786941\n"
  },
  {
    "path": "Math/modular_fibonacci_anynum.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 19 June 2018\n# https://github.com/trizen\n\n# An efficient algorithm for computing the nth-Fibonacci number (mod m).\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload ilog2 getbit);\n\nsub fibonacci_number($n, $m) {\n\n    my ($f, $g) = (0, 1);\n    my ($a, $b) = (0, 1);\n\n    foreach my $k (0 .. ilog2($n)||0) {\n        ($f, $g) = (($f*$a + $g*$b)%$m, ($f*$b + $g*($a+$b))%$m) if getbit($n, $k);\n        ($a, $b) = (($a*$a + $b*$b)%$m, ($a*$b + $b*($a+$b))%$m);\n    }\n\n    return $f;\n}\n\n# Last 20 digits of the 10^100-th Fibonacci number\nsay fibonacci_number(10**100, 10**20);       #=> 59183788299560546875\n"
  },
  {
    "path": "Math/modular_fibonacci_cassini.pl",
    "content": "#!/usr/bin/perl\n\n# An efficient algorithm for computing the nth-Fibonacci number (mod m).\n\n# Algorithm from:\n#   https://metacpan.org/source/KRYDE/Math-NumSeq-72/lib/Math/NumSeq/Fibonacci.pm\n\n# See also:\n#   https://en.wikipedia.org/wiki/Fibonacci_number\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse Math::GMPz;\nuse Math::Prime::Util::GMP qw(consecutive_integer_lcm gcd);\n\nsub fibmod ($n, $m) {\n\n    $n = Math::GMPz->new(\"$n\");\n    $m = Math::GMPz->new(\"$m\");\n\n    my ($f, $g, $a) = (0, 1, -2);\n\n    foreach my $bit (split(//, substr(Math::GMPz::Rmpz_get_str($n, 2), 1))) {\n\n        ($g *= $g) %= $m;\n        ($f *= $f) %= $m;\n\n        my $t = ($g << 2) - $f + $a;\n\n        $f += $g;\n\n        if ($bit) {\n            ($f, $g, $a) = ($t - $f, $t, -2);\n        }\n        else {\n            ($g, $a) = ($t - $f, 2);\n        }\n    }\n\n    return ($g % $m);\n}\n\nsub fibonacci_factorization ($n, $B = 10000) {\n\n    my $k = consecutive_integer_lcm($B);    # lcm(1..B)\n    my $F = fibmod($k, $n);                 # Fibonacci(k) (mod n)\n\n    return gcd($F, $n);\n}\n\nsay fibonacci_factorization(\"121095274043\",             700);     #=> 470783           (p+1 is  700-smooth)\nsay fibonacci_factorization(\"544812320889004864776853\", 3000);    #=> 333732865481     (p-1 is 3000-smooth)\n"
  },
  {
    "path": "Math/modular_fibonacci_cassini_fast.pl",
    "content": "#!/usr/bin/perl\n\n# An efficient algorithm for computing the nth-Fibonacci number (mod m).\n\n# Algorithm from:\n#   https://metacpan.org/source/KRYDE/Math-NumSeq-72/lib/Math/NumSeq/Fibonacci.pm\n\n# See also:\n#   https://en.wikipedia.org/wiki/Fibonacci_number\n\nuse 5.020;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Math::GMPz;\nuse Math::Prime::Util::GMP qw(gcd consecutive_integer_lcm);\n\nsub fibmod ($n, $m) {\n\n    $n = Math::GMPz->new(\"$n\");\n    $m = Math::GMPz->new(\"$m\");\n\n    my ($f, $g, $w) = (\n        Math::GMPz::Rmpz_init_set_ui(0),\n        Math::GMPz::Rmpz_init_set_ui(1),\n    );\n\n    my $t = Math::GMPz::Rmpz_init();\n\n    foreach my $bit (split(//, substr(Math::GMPz::Rmpz_get_str($n, 2), 1))) {\n\n        Math::GMPz::Rmpz_powm_ui($g, $g, 2, $m);\n        Math::GMPz::Rmpz_powm_ui($f, $f, 2, $m);\n\n        Math::GMPz::Rmpz_mul_2exp($t, $g, 2);\n        Math::GMPz::Rmpz_sub($t, $t, $f);\n\n        $w\n          ? Math::GMPz::Rmpz_add_ui($t, $t, 2)\n          : Math::GMPz::Rmpz_sub_ui($t, $t, 2);\n\n        Math::GMPz::Rmpz_add($f, $f, $g);\n\n        if ($bit) {\n            Math::GMPz::Rmpz_sub($f, $t, $f);\n            Math::GMPz::Rmpz_set($g, $t);\n            $w = 0;\n        }\n        else {\n            Math::GMPz::Rmpz_sub($g, $t, $f);\n            $w = 1;\n        }\n    }\n\n    Math::GMPz::Rmpz_mod($g, $g, $m);\n\n    return $g;\n}\n\nsub fibonacci_factorization ($n, $B = 10000) {\n\n    my $k = consecutive_integer_lcm($B);    # lcm(1..B)\n    my $F = fibmod($k, $n);                 # Fibonacci(k) (mod n)\n\n    return gcd($F, $n);\n}\n\nsay fibonacci_factorization(\"121095274043\",             700);     #=> 470783           (p+1 is  700-smooth)\nsay fibonacci_factorization(\"544812320889004864776853\", 3000);    #=> 333732865481     (p-1 is 3000-smooth)\n"
  },
  {
    "path": "Math/modular_fibonacci_fast_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 19 June 2018\n# https://github.com/trizen\n\n# An efficient algorithm for computing the nth-Fibonacci number (mod m).\n\n# See also:\n#   https://en.wikipedia.org/wiki/Fibonacci_number\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\nuse experimental qw(signatures);\n\nsub modular_fibonacci ($n, $m) {\n\n    $n = Math::GMPz->new(\"$n\");\n    $m = Math::GMPz->new(\"$m\");\n\n    state $t = Math::GMPz::Rmpz_init_nobless();\n    state $u = Math::GMPz::Rmpz_init_nobless();\n\n    my $f = Math::GMPz::Rmpz_init_set_ui(0);    # set to 2 for Lucas numbers\n    my $g = Math::GMPz::Rmpz_init_set_ui(1);\n\n    my $A = Math::GMPz::Rmpz_init_set_ui(0);\n    my $B = Math::GMPz::Rmpz_init_set_ui(1);\n\n    my @bits = split(//, Math::GMPz::Rmpz_get_str($n, 2));\n\n    while (@bits) {\n\n        if (pop @bits) {\n\n            # (f, g) = (f*a + g*b, f*b + g*(a+b))  mod m\n\n            Math::GMPz::Rmpz_mul($u, $g, $B);\n            Math::GMPz::Rmpz_mul($t, $f, $A);\n            Math::GMPz::Rmpz_mul($g, $g, $A);\n\n            Math::GMPz::Rmpz_add($t, $t, $u);\n            Math::GMPz::Rmpz_add($g, $g, $u);\n\n            Math::GMPz::Rmpz_addmul($g, $f, $B);\n\n            Math::GMPz::Rmpz_mod($f, $t, $m);\n            Math::GMPz::Rmpz_mod($g, $g, $m);\n        }\n\n        # (a, b) = (a*a + b*b, a*b + b*(a+b))  mod m\n\n        Math::GMPz::Rmpz_mul($t, $A, $A);\n        Math::GMPz::Rmpz_mul($u, $B, $B);\n\n        Math::GMPz::Rmpz_mul($B, $B, $A);\n        Math::GMPz::Rmpz_mul_2exp($B, $B, 1);\n\n        Math::GMPz::Rmpz_add($B, $B, $u);\n        Math::GMPz::Rmpz_add($t, $t, $u);\n\n        Math::GMPz::Rmpz_mod($A, $t, $m);\n        Math::GMPz::Rmpz_mod($B, $B, $m);\n    }\n\n    return $f;\n}\n\nsay \"=> Last 20 digits of the 10^100-th Fibonacci number:\";\nsay modular_fibonacci(Math::GMPz->new(10)**100, Math::GMPz->new(10)**20);\n\nsay \"\\n=> First few Fibonacci numbers:\";\nsay join(' ', map { modular_fibonacci($_, 10**9) } 0 .. 25);\n\nsay \"\\n=> Last digit of Fibonacci numbers: \";\nsay join(' ', map { modular_fibonacci($_, 10) } 0 .. 50);\n"
  },
  {
    "path": "Math/modular_fibonacci_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 22 June 2017\n# https://github.com/trizen\n\n# An efficient algorithm for computing large Fibonacci numbers, modulo some n.\n\n# Algorithm from:\n#   https://codeforces.com/blog/entry/14516\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::GMPz qw();\nuse experimental qw(signatures);\n\nsub fibmod($n, $mod, $cache={}) {\n\n    $n <= 1 && return $n;\n\n    sub ($n) {\n\n        $n <= 1 && return do {\n            state $one = Math::GMPz::Rmpz_init_set_ui(1)\n        };\n\n        if (exists($cache->{$n})) {\n            return $cache->{$n};\n        }\n\n        my $k = $n >> 1;\n\n        $cache->{$n} = (\n                        $n % 2 == 0\n                        ? (__SUB__->($k) * __SUB__->($k)     + __SUB__->($k - 1) * __SUB__->($k - 1)) % $mod\n                        : (__SUB__->($k) * __SUB__->($k + 1) + __SUB__->($k - 1) * __SUB__->($k)    ) % $mod\n                       );\n    }->($n - 1);\n}\n\nsay fibmod(329468, 10**10, {});     # 352786941\n"
  },
  {
    "path": "Math/modular_fibonacci_polynomial.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 11 October 2017\n# https://github.com/trizen\n\n# Algorithm for computing a Fibonacci polynomial modulo m.\n\n#   (Sum_{k=1..n} (fibonacci(k) * x^k)) (mod m)\n\n# See also:\n#   https://projecteuler.net/problem=435\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures lexical_subs);\nuse ntheory qw(lcm addmod mulmod factor_exp powmod);\n\nsub pisano_period($mod) {\n\n    my sub find_period($mod) {\n        my ($x, $y) = (0, 1);\n\n        for (my $n = 1 ; ; ++$n) {\n            ($x, $y) = ($y, addmod($x, $y, $mod));\n\n            if ($x == 0 and $y == 1) {\n                return $n;\n            }\n        }\n    }\n\n    my @prime_powers  = map { $_->[0]**$_->[1] } factor_exp($mod);\n    my @power_periods = map { find_period($_) } @prime_powers;\n\n    return lcm(@power_periods);\n}\n\nsub modular_fibonacci_polynomial ($n, $x, $mod) {\n\n    $n %= pisano_period($mod);\n\n    my $sum = 0;\n\n    my ($f1, $f2) = (0, 1);\n    foreach my $k (1 .. $n) {\n        $sum = addmod($sum, mulmod($f2, powmod($x, $k, $mod), $mod), $mod);\n        ($f1, $f2) = ($f2, addmod($f1, $f2, $mod));\n    }\n\n    return $sum;\n}\n\nsay modular_fibonacci_polynomial(7,      11, 100000);        #=> 57683\nsay modular_fibonacci_polynomial(10**15, 13, 6227020800);    #=> 4631902275\n"
  },
  {
    "path": "Math/modular_fibonacci_polynomial_2.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 11 October 2017\n# https://github.com/trizen\n\n# Algorithm for computing a Fibonacci polynomial modulo m.\n\n#   (Sum_{k=1..n} (fibonacci(k) * x^k)) (mod m)\n\n# See also:\n#   https://projecteuler.net/problem=435\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(addmod mulmod powmod factor_exp chinese);\n\nsub modular_fibonacci_polynomial ($n, $x, $m) {\n\n    my @chinese;\n    foreach my $p (factor_exp($m)) {\n\n        my $pp = $p->[0]**$p->[1];\n\n        my $sum = 0;\n        my ($f1, $f2) = (0, 1);\n\n        my @array;\n        foreach my $k (1 .. $n) {\n\n            $sum = addmod($sum, mulmod($f2, powmod($x, $k, $pp), $pp), $pp);\n\n            push @array, $sum;\n\n            ($f1, $f2) = ($f2, addmod($f1, $f2, $pp));\n\n            if ($f1 == 0 and $f2 == 1 and $k > 20 and\n                    join(' ', @array[9              .. $#array/2])\n                 eq join(' ', @array[$#array/2 + 10 .. $#array])\n            ) {\n                $sum = $array[($n % $k) - 1];\n                last;\n            }\n        }\n\n        push @chinese, [$sum, $pp];\n    }\n\n    return chinese(@chinese);\n}\n\nsay modular_fibonacci_polynomial(7,      11, 100000);        #=> 57683\nsay modular_fibonacci_polynomial(10**15, 13, 6227020800);    #=> 4631902275\n"
  },
  {
    "path": "Math/modular_hyperoperation.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 27 August 2016\n# Edit: 20 April 2019\n# https://github.com/trizen\n\n# Generalized implementation of Knuth's up-arrow hyperoperation (modulo some m).\n\n# See also:\n#   https://en.wikipedia.org/wiki/Knuth%27s_up-arrow_notation\n\nuse utf8;\nuse 5.020;\nuse strict;\nuse warnings;\n\nno warnings 'recursion';\nuse experimental qw(signatures);\n\nbinmode(STDOUT, ':utf8');\n\nuse Memoize qw(memoize);\nuse ntheory qw(powmod euler_phi forprimes);\n\nmemoize('knuth');\nmemoize('hyper1');\nmemoize('hyper2');\nmemoize('hyper3');\nmemoize('hyper4');\n\nsub hyper1 ($n, $k, $m) {\n    powmod($n, $k, $m);\n}\n\nsub hyper2 ($n, $k, $m) {\n\n    return 0 if ($m == 1);\n    return 1 if ($k == 0);\n\n    hyper1($n, hyper2($n, $k-1, euler_phi($m)), $m);\n}\n\nsub hyper3 ($n, $k, $m) {\n\n    return 0 if ($m == 1);\n    return 1 if ($k == 0);\n\n    hyper2($n, hyper3($n, $k-1, euler_phi($m)), $m);\n}\n\nsub hyper4 ($n, $k, $m) {\n\n    return 0 if ($m == 1);\n    return 1 if ($k == 0);\n\n    hyper3($n, hyper4($n, $k-1, euler_phi($m)), $m);\n}\n\nsub knuth ($k, $n, $g, $m) {\n\n    $n >= 1 and $g == 0 and return 1;\n\n    $n == 0 and return (($k * $g) % $m);\n    $n == 1 and return hyper1($k, $g, $m);\n    $n == 2 and return hyper2($k, $g, $m);\n    $n == 3 and return hyper3($k, $g, $m);\n    $n == 4 and return hyper4($k, $g, $m);\n\n    knuth($k, $n - 1, knuth($k, $n, $g - 1, $m), $m);\n}\n\nmy $m = 10**3;\n\nforeach my $i (0 .. 6) {\n\n    my $x = 1 + int(rand(100));\n    my $y = 1 + int(rand(100));\n\n    my $n = knuth($x, $i, $y, $m);\n    printf(\"%5s %10s %5s = %5s   (mod %s)\\n\", $x, '↑' x $i, $y, $n, $m);\n}\n\nsay \"\\n=> Finding prime factors of 10↑↑10 + 23:\";\n\nforprimes {\n    if (((knuth(10, 2, 10, $_) + 23) % $_) == 0) {\n        printf(\"%6s | (10↑↑10 + 23)\\n\", $_);\n    }\n} 1e6;\n\n__END__\n   47               20 =   940   (mod 1000)\n   84          ↑    59 =   664   (mod 1000)\n   49         ↑↑    79 =   449   (mod 1000)\n   95        ↑↑↑    71 =   375   (mod 1000)\n    7       ↑↑↑↑    41 =   343   (mod 1000)\n   40      ↑↑↑↑↑     7 =    40   (mod 1000)\n   17     ↑↑↑↑↑↑    55 =   777   (mod 1000)\n\n=> Finding prime factors of 10↑↑10 + 23:\n     2 | (10↑↑10 + 23)\n     3 | (10↑↑10 + 23)\n    13 | (10↑↑10 + 23)\n   673 | (10↑↑10 + 23)\n 18301 | (10↑↑10 + 23)\n400109 | (10↑↑10 + 23)\n"
  },
  {
    "path": "Math/modular_inverse.pl",
    "content": "#!/usr/bin/perl\n\n# Algorithm for computing the modular inverse: 1/k mod n, with gcd(k, n) = 1.\n\n# Algorithm presented in the book:\n#\n#   Modern Computer Arithmetic\n#           - by Richard P. Brent and Paul Zimmermann\n#\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nsub divmod ($n, $k) {\n    (int($n / $k), $n % $k);\n}\n\nsub modular_inverse ($k, $n) {\n\n    my ($u, $w) = (1, 0);\n    my ($q, $r) = (0, 0);\n\n    my $c = $n;\n\n    while ($c != 0) {\n        ($q, $r) = divmod($k, $c);\n        ($k, $c) = ($c, $r);\n        ($u, $w) = ($w, $u - $q*$w);\n    }\n\n    $u += $n if ($u < 0);\n\n    return $u;\n}\n\nsay modular_inverse(42, 2017);      #=> 1969\n"
  },
  {
    "path": "Math/modular_k-th_root_all_solutions.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 09 December 2025\n# Edit: 10 December 2025\n# https://github.com/trizen\n\n# kth_root_mod: find all x (0 <= x < m) with x^k ≡ a (mod m)\n\nuse 5.036;\nuse Test::More tests => 60;\nuse Math::Prime::Util qw(:all);\n\n# Solve x^k ≡ r (mod p) for prime p.\nsub solve_mod_p($k, $r, $p) {\n    die \"p must be prime > 1\" unless $p > 1 && is_prime($p);\n    $r %= $p;\n\n    return (0)                                           if $r == 0;    # trivial zero solution\n    return grep { powmod($_, $k, $p) == $r } 0 .. $p - 1 if $p <= 31;\n\n    my $phi = $p - 1;\n    my $d   = gcd($k, $phi);\n    return () if powmod($r, $phi / $d, $p) != 1;                        # necessary condition\n\n    return ($r) if $k == 1;\n\n    my $g = znprimroot($p) // return grep { powmod($_, $k, $p) == $r } 0 .. $p - 1;\n    my $a = znlog($r, $g, $p);\n    return () unless defined $a;\n\n    my $k1   = divint($k,   $d);\n    my $phi1 = divint($phi, $d);\n    my $a1   = divint($a,   $d);\n    my $t0   = ($a1 * invmod($k1, $phi1)) % $phi1;\n\n    return map { powmod($g, $t0 + $_ * $phi1, $p) } 0 .. $d - 1;\n}\n\n# Solve x^k ≡ r (mod p^e) for prime powers by lifting.\nsub solve_prime_power_lift($k, $r, $p, $e) {\n    my $mod = powint($p, $e);\n\n    $r %= $mod;\n\n    return () if $mod == 0;\n\n    if ($r % $mod == 0) {    # x^k ≡ 0\n        my $vx_min = divint($e + $k - 1, $k);    # ceil(e / k)\n        my $base   = powint($p, $vx_min);\n        return map { $_ * $base } 0 .. (powint($p, $e - $vx_min) - 1);\n    }\n\n    my @sol_t = solve_mod_p($k, $r, $p);         # solutions mod p\n    return () unless @sol_t;\n    return @sol_t if $e == 1;\n\n    my $t = 1;\n    while ($t < $e) {                            # lift to p^{t+1}\n        my $next_mod = powint($p, $t + 1);\n        my @next;\n        for my $a (@sol_t) {\n            my $base = powint($p, $t);\n            for my $s (0 .. $p - 1) {\n                my $cand = ($a + $s * $base) % $next_mod;\n                push @next, $cand if powmod($cand, $k, $next_mod) == ($r % $next_mod);\n            }\n        }\n        @sol_t = @next;\n        return () unless @sol_t;\n        $t++;\n    }\n\n    return @sol_t;\n}\n\n# All solutions to x^k ≡ r (mod m).\nsub kth_root_mod($k, $r, $m) {\n    return () if $m == 0;\n\n    if ($k == 0 and $r == 1) {\n        return (0 .. $m - 1);\n    }\n\n    # Support negative k: solve y^{|k|} ≡ r and invert solutions y -> x = y^{-1}\n    if ($k < 0) {\n\n        # r must be a unit modulo m to be a power of a unit\n        return () if gcd($r, $m) != 1;\n        my @yinv = kth_root_mod(-$k, $r, $m);    # recursive call with positive exponent\n        return () unless @yinv;\n        my @xs;\n        for my $y (@yinv) {\n            my $y_mod = $y % $m;\n            my $inv   = invmod($y_mod, $m);\n            push @xs, $inv if defined $inv;      # should be defined because y is a unit\n        }\n        return sort { $a <=> $b } @xs;\n    }\n\n    my @factors = factor_exp($m);    # [p, e] pairs\n    my @current = ([0, 1]);          # [residue, modulus]\n\n    for my $fe (@factors) {\n        my ($p, $e) = @$fe;\n        my $mod_pe = powint($p, $e);\n        my @sol_pe = solve_prime_power_lift($k, $r % $mod_pe, $p, $e);\n        return () unless @sol_pe;\n\n        my @next;\n        for my $pe (@sol_pe) {\n            for my $cur (@current) {\n                my ($A, $mod_a) = @$cur;\n                push @next, [chinese([$A, $mod_a], [$pe, $mod_pe]), $mod_a * $mod_pe];\n            }\n        }\n        @current = @next;\n    }\n\n    return sort { $a <=> $b } map { $_->[0] % $m } @current;\n}\n\nis_deeply([kth_root_mod(3, 2, 101)], [26]);\nis_deeply([kth_root_mod(2, 0, 16)],  [0, 4, 8, 12]);\nis_deeply([kth_root_mod(2, 1, 101)], [1, 100]);\nis_deeply([kth_root_mod(5, 4320, 5040)],\n          [120, 330, 540, 750, 960, 1170, 1380, 1590, 1800, 2010, 2220, 2430, 2640, 2850, 3060, 3270, 3480, 3690, 3900, 4110, 4320, 4530, 4740, 4950]);\nis_deeply(\n          [kth_root_mod(6, 4320, 5040)],\n          [30,   60,   90,   120,  150,  180,  240,  270,  300,  330,  360,  390,  450,  480,  510,  540,  570,  600,  660,  690,  720,  750,  780,  810,\n           870,  900,  930,  960,  990,  1020, 1080, 1110, 1140, 1170, 1200, 1230, 1290, 1320, 1350, 1380, 1410, 1440, 1500, 1530, 1560, 1590, 1620, 1650,\n           1710, 1740, 1770, 1800, 1830, 1860, 1920, 1950, 1980, 2010, 2040, 2070, 2130, 2160, 2190, 2220, 2250, 2280, 2340, 2370, 2400, 2430, 2460, 2490,\n           2550, 2580, 2610, 2640, 2670, 2700, 2760, 2790, 2820, 2850, 2880, 2910, 2970, 3000, 3030, 3060, 3090, 3120, 3180, 3210, 3240, 3270, 3300, 3330,\n           3390, 3420, 3450, 3480, 3510, 3540, 3600, 3630, 3660, 3690, 3720, 3750, 3810, 3840, 3870, 3900, 3930, 3960, 4020, 4050, 4080, 4110, 4140, 4170,\n           4230, 4260, 4290, 4320, 4350, 4380, 4440, 4470, 4500, 4530, 4560, 4590, 4650, 4680, 4710, 4740, 4770, 4800, 4860, 4890, 4920, 4950, 4980, 5010\n          ]\n         );\nis_deeply(\n          [kth_root_mod(124, 2016, 5040)],\n          [42,   84,   126,  168,  252,  294,  336,  378,  462,  504,  546,  588,  672,  714,  756,  798,  882,  924,  966,  1008, 1092, 1134, 1176, 1218,\n           1302, 1344, 1386, 1428, 1512, 1554, 1596, 1638, 1722, 1764, 1806, 1848, 1932, 1974, 2016, 2058, 2142, 2184, 2226, 2268, 2352, 2394, 2436, 2478,\n           2562, 2604, 2646, 2688, 2772, 2814, 2856, 2898, 2982, 3024, 3066, 3108, 3192, 3234, 3276, 3318, 3402, 3444, 3486, 3528, 3612, 3654, 3696, 3738,\n           3822, 3864, 3906, 3948, 4032, 4074, 4116, 4158, 4242, 4284, 4326, 4368, 4452, 4494, 4536, 4578, 4662, 4704, 4746, 4788, 4872, 4914, 4956, 4998\n          ]\n         );\nis_deeply([kth_root_mod(5, 43,  5040)], [1723]);\nis_deeply([kth_root_mod(5, 243, 1000)], [3, 203, 403, 603, 803]);\nis_deeply(\n          [kth_root_mod(383, 32247425005, 64552988163)],\n          [49,          168545710,   337091371,   505637032,   674182693,   842728354,   1011274015,  1179819676,  1348365337,  1516910998,\n           1685456659,  1854002320,  2022547981,  2191093642,  2359639303,  2528184964,  2696730625,  2865276286,  3033821947,  3202367608,\n           3370913269,  3539458930,  3708004591,  3876550252,  4045095913,  4213641574,  4382187235,  4550732896,  4719278557,  4887824218,\n           5056369879,  5224915540,  5393461201,  5562006862,  5730552523,  5899098184,  6067643845,  6236189506,  6404735167,  6573280828,\n           6741826489,  6910372150,  7078917811,  7247463472,  7416009133,  7584554794,  7753100455,  7921646116,  8090191777,  8258737438,\n           8427283099,  8595828760,  8764374421,  8932920082,  9101465743,  9270011404,  9438557065,  9607102726,  9775648387,  9944194048,\n           10112739709, 10281285370, 10449831031, 10618376692, 10786922353, 10955468014, 11124013675, 11292559336, 11461104997, 11629650658,\n           11798196319, 11966741980, 12135287641, 12303833302, 12472378963, 12640924624, 12809470285, 12978015946, 13146561607, 13315107268,\n           13483652929, 13652198590, 13820744251, 13989289912, 14157835573, 14326381234, 14494926895, 14663472556, 14832018217, 15000563878,\n           15169109539, 15337655200, 15506200861, 15674746522, 15843292183, 16011837844, 16180383505, 16348929166, 16517474827, 16686020488,\n           16854566149, 17023111810, 17191657471, 17360203132, 17528748793, 17697294454, 17865840115, 18034385776, 18202931437, 18371477098,\n           18540022759, 18708568420, 18877114081, 19045659742, 19214205403, 19382751064, 19551296725, 19719842386, 19888388047, 20056933708,\n           20225479369, 20394025030, 20562570691, 20731116352, 20899662013, 21068207674, 21236753335, 21405298996, 21573844657, 21742390318,\n           21910935979, 22079481640, 22248027301, 22416572962, 22585118623, 22753664284, 22922209945, 23090755606, 23259301267, 23427846928,\n           23596392589, 23764938250, 23933483911, 24102029572, 24270575233, 24439120894, 24607666555, 24776212216, 24944757877, 25113303538,\n           25281849199, 25450394860, 25618940521, 25787486182, 25956031843, 26124577504, 26293123165, 26461668826, 26630214487, 26798760148,\n           26967305809, 27135851470, 27304397131, 27472942792, 27641488453, 27810034114, 27978579775, 28147125436, 28315671097, 28484216758,\n           28652762419, 28821308080, 28989853741, 29158399402, 29326945063, 29495490724, 29664036385, 29832582046, 30001127707, 30169673368,\n           30338219029, 30506764690, 30675310351, 30843856012, 31012401673, 31180947334, 31349492995, 31518038656, 31686584317, 31855129978,\n           32023675639, 32192221300, 32360766961, 32529312622, 32697858283, 32866403944, 33034949605, 33203495266, 33372040927, 33540586588,\n           33709132249, 33877677910, 34046223571, 34214769232, 34383314893, 34551860554, 34720406215, 34888951876, 35057497537, 35226043198,\n           35394588859, 35563134520, 35731680181, 35900225842, 36068771503, 36237317164, 36405862825, 36574408486, 36742954147, 36911499808,\n           37080045469, 37248591130, 37417136791, 37585682452, 37754228113, 37922773774, 38091319435, 38259865096, 38428410757, 38596956418,\n           38765502079, 38934047740, 39102593401, 39271139062, 39439684723, 39608230384, 39776776045, 39945321706, 40113867367, 40282413028,\n           40450958689, 40619504350, 40788050011, 40956595672, 41125141333, 41293686994, 41462232655, 41630778316, 41799323977, 41967869638,\n           42136415299, 42304960960, 42473506621, 42642052282, 42810597943, 42979143604, 43147689265, 43316234926, 43484780587, 43653326248,\n           43821871909, 43990417570, 44158963231, 44327508892, 44496054553, 44664600214, 44833145875, 45001691536, 45170237197, 45338782858,\n           45507328519, 45675874180, 45844419841, 46012965502, 46181511163, 46350056824, 46518602485, 46687148146, 46855693807, 47024239468,\n           47192785129, 47361330790, 47529876451, 47698422112, 47866967773, 48035513434, 48204059095, 48372604756, 48541150417, 48709696078,\n           48878241739, 49046787400, 49215333061, 49383878722, 49552424383, 49720970044, 49889515705, 50058061366, 50226607027, 50395152688,\n           50563698349, 50732244010, 50900789671, 51069335332, 51237880993, 51406426654, 51574972315, 51743517976, 51912063637, 52080609298,\n           52249154959, 52417700620, 52586246281, 52754791942, 52923337603, 53091883264, 53260428925, 53428974586, 53597520247, 53766065908,\n           53934611569, 54103157230, 54271702891, 54440248552, 54608794213, 54777339874, 54945885535, 55114431196, 55282976857, 55451522518,\n           55620068179, 55788613840, 55957159501, 56125705162, 56294250823, 56462796484, 56631342145, 56799887806, 56968433467, 57136979128,\n           57305524789, 57474070450, 57642616111, 57811161772, 57979707433, 58148253094, 58316798755, 58485344416, 58653890077, 58822435738,\n           58990981399, 59159527060, 59328072721, 59496618382, 59665164043, 59833709704, 60002255365, 60170801026, 60339346687, 60507892348,\n           60676438009, 60844983670, 61013529331, 61182074992, 61350620653, 61519166314, 61687711975, 61856257636, 62024803297, 62193348958,\n           62361894619, 62530440280, 62698985941, 62867531602, 63036077263, 63204622924, 63373168585, 63541714246, 63710259907, 63878805568,\n           64047351229, 64215896890, 64384442551\n          ]\n         );\n\nis_deeply(\n          [kth_root_mod(3432, 33, 10428581733134514527),],\n          [234538669356049904,  265172539733867379,  338494374696194946,  468144956219368759,   587920784072174975,   866212217277838851,\n           1191587698502237300, 1469879131707901176, 2012837926243083376, 2116793631583228418,  2246444213106402231,  2616504840673145701,\n           2819477257158647081, 2850111127536464556, 2969886955389270772, 3248178388594934648,  3672570580964689435,  3950862014170353311,\n           4095753547647065419, 4374044980852729295, 4597776514045680553, 4699420462077127744,  4977711895282791620,  5201443428475742878,\n           5227138304658771649, 5450869837851722907, 5729161271057386783, 5830805219088833974,  6054536752281785232,  6332828185487449108,\n           6477719718964161216, 6756011152169825092, 7180403344539579879, 7458694777745243755,  7578470605598049971,  7609104475975867446,\n           7812076892461368826, 8182137520028112296, 8311788101551286109, 8415743806891431151,  8958702601426613351,  9236994034632277227,\n           9562369515856675676, 9840660949062339552, 9960436776915145768, 10090087358438319581, 10163409193400647148, 10194043063778464623\n          ]\n         );\n\n# Check:\n#   p {prime, prime power, square-free composite, non-SF composite}\n#   k {prime, prime power, square-free composite, non-SF composite}\nmy @rootmods = (\n\n    # prime moduli\n    [14,    -3, 101,    [17]],\n    [13,     6, 107,    [24, 83]],\n    [13,    -6, 107,    [49, 58]],\n    [64,     6, 101,    [2,  99]],\n    [9,     -2, 101,    [34, 67]],\n    [2,      3, 3,      [2]],\n    [2,      3, 7,      undef],\n    [17,    29, 19,     [6]],\n    [5,      3, 13,     [7,     8,  11]],\n    [53,     3, 151,    [15,    27, 109]],\n    [3,      3, 73,     [25,    54, 67]],\n    [7,      3, 73,     [13,    29, 31]],\n    [49,     3, 73,     [12,    23, 38]],\n    [44082,  4, 100003, [2003,  98000]],\n    [90594,  6, 100019, [37071, 62948]],\n    [6,      5, 31,     [11,    13, 21, 22, 26]],\n    [0,      2, 2,      [0]],\n    [2,      4, 5,      undef],\n    [51,    12, 10009,  [64, 1203, 3183, 3247, 3999, 4807, 5202, 6010, 6762, 6826, 8806, 9945]],\n\n    #[15,3,\"1000000000000000000117\",[qw/72574612502199260377 361680004182786118804 565745383315014620936/]],\n    [1,  0, 13, [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12]],\n    [2,  0, 13, undef],\n    [0,  5, 0,  undef],\n    [0, -1, 3,  undef],\n\n    # composite moduli.\n    # Pari will usually give a *wrong* answer for these if using Mod(a,p).\n    # The right way with Pari is to use p-adic.\n    [4,  2, 10,   [2, 8]],\n    [4,  2, 18,   [2, 16]],\n    [2,  3, 21,   undef],                                                # Pari says 2\n    [8,  3, 27,   [2,   11,  20]],                                       # Pari says 26\n    [22, 3, 1505, [148, 578, 673, 793, 813, 1103, 1243, 1318, 1458]],    # Pari says 1408\n    [58787, 3, 100035,\n     [3773,  8633,  10793, 13763, 19163, 24293, 26183, 26588, 31313, 37118, 41978, 44138, 47108, 52508,\n      57638, 59528, 59933, 64658, 70463, 75323, 77483, 80453, 85853, 90983, 92873, 93278, 98003\n     ]\n    ],\n    [3748, 2, 4992,\n     [154,  262,  314,  518,  730,  934,  986,  1094, 1402, 1510, 1562, 1766, 1978, 2182, 2234, 2342,\n      2650, 2758, 2810, 3014, 3226, 3430, 3482, 3590, 3898, 4006, 4058, 4262, 4474, 4678, 4730, 4838\n     ]\n    ],\n    [68,           2,  2048, [46,  466, 558, 978,  1070, 1490, 1582, 2002]],\n    [96,           5,  128,  [6,   14,  22,  30,   38,   46,   54,   62,   70,   78,   86,   94,   102,  110,  118,  126]],\n    [2912,         5,  4992, [182, 494, 806, 1118, 1430, 1742, 2054, 2366, 2678, 2990, 3302, 3614, 3926, 4238, 4550, 4862]],\n    [2,            3,  4,    undef],\n    [3,            2,  4,    undef],\n    [3,            4,  19,   undef],\n    [1,            4,  20,   [1, 3, 7,  9, 11, 13, 17, 19]],\n    [9,            2,  24,   [3, 9, 15, 21]],\n    [6,            6,  35,   undef],\n    [36,           2,  40,   [6, 14, 26, 34]],\n    [16,           12, 48,   [2, 4,  8,  10, 14, 16, 20, 22, 26, 28, 32, 34, 38, 40, 44, 46]],\n    [13,           6,  112,  undef],\n    [52,           6,  117,  undef],\n    [48,           3,  128,  undef],\n    [382,          3,  1000, undef],\n    [10,           3,  81,   [13, 40,  67]],\n    [26,           5,  625,  [81, 206, 331, 456, 581]],\n    [51,           5,  625,  [61, 186, 311, 436, 561]],\n    [\"9833625071\", 3,  \"10000000071\", [qw/3333332807 6666666164 9999999521/]],\n\n    #[2131968,5,10000000000, [...]],   # Far too many\n    [198, -1, 519, undef],\n);\n\nforeach my $t (@rootmods) {\n    say \"Testing: kth_root_mod($t->[1], $t->[0], $t->[2])\";\n    is_deeply([kth_root_mod($t->[1], $t->[0], $t->[2])], (defined($t->[3]) ? $t->[3] : []));\n}\n\n# ----- CLI usage -----\nif (@ARGV == 3) {\n    my ($k, $v, $m) = @ARGV;\n    my @sol = kth_root_mod($k, $v, $m);\n    if (!@sol) {\n        print \"No solution: x^$k ≡ $v (mod $m) has no solution.\\n\";\n    }\n    else {\n        print scalar(@sol),                        \" solution(s) mod $m:\\n\";\n        print join(\", \", sort { $a <=> $b } @sol), \"\\n\";\n    }\n    exit 0;\n}\n"
  },
  {
    "path": "Math/modular_k-th_root_all_solutions_fast.pl",
    "content": "#!/usr/bin/perl\n\n# kth_root_mod: find all x (0 <= x < m) with x^k ≡ a (mod m)\n\n# Based on code from Math::Prime::Util::PP by Dana Jacobsen.\n\nuse 5.036;\nuse ntheory qw(:all);\nuse Test::More tests => 60;\n\n#----------------------------------------------------------\n# Tonelli-Shanks algorithm for k-th roots modulo a prime\n#----------------------------------------------------------\nsub _tonelli_shanks($a, $k, $p) {\n    my ($exp, $q) = (0, $p - 1);\n    ($exp++, $q = divint($q, $k)) while $q % $k == 0;\n\n    my $k_exp = divint($p - 1, $q);\n    my $root  = powmod($a, invmod($k % $q, $q), $p);\n    my $b     = mulmod(powmod($root, $k, $p), invmod($a, $p), $p);\n\n    # Find a generator of the k-th roots of unity\n    my ($candidate, $zeta, $gen) = (2, 1, undef);\n    until ($zeta != 1) {\n        $gen  = powmod($candidate++, $q,                 $p);\n        $zeta = powmod($gen,         divint($k_exp, $k), $p);\n    }\n\n    # Iteratively refine the root\n    while ($k_exp != $k) {\n        $k_exp = divint($k_exp, $k);\n        ($candidate, $gen) = ($gen, powmod($gen, $k, $p));\n        my $test = powmod($b, divint($k_exp, $k), $p);\n        while ($test != 1) {\n            $root = mulmod($root, $candidate, $p);\n            $b    = mulmod($b,    $gen,       $p);\n            $test = mulmod($test, $zeta,      $p);\n        }\n    }\n\n    return ($root, $gen);\n}\n\n#----------------------------------------------------------\n# Chinese Remainder Theorem:  combine roots from two moduli\n#----------------------------------------------------------\nsub _crt_combine($roots_a, $mod_a, $roots_b, $mod_b) {\n    my $mod = mulint($mod_a, $mod_b);\n    my $inv = invmod($mod_a, $mod_b) // die \"CRT: undefined inverse\";\n\n    my @roots;\n    foreach my $ra (@$roots_a) {\n        foreach my $rb (@$roots_b) {\n            my $diff = mulmod($inv, submod($rb, $ra, $mod_b), $mod_b);\n            push @roots, addmod(mulmod($mod_a, $diff, $mod), $ra, $mod);\n        }\n    }\n\n    return @roots;\n}\n\n#----------------------------------------------------------\n# All k-th roots of a modulo prime p\n#----------------------------------------------------------\nsub _roots_mod_prime($a, $k, $p) {\n    $a %= $p;\n    return ($a) if $p == 2 || $a == 0;\n\n    my $phi = $p - 1;\n    my $g   = gcd($k, $phi);\n\n    # Unique root when gcd(k, p-1) = 1\n    return (powmod($a, invmod($k % $phi, $phi), $p)) if $g == 1;\n\n    # No roots if a is not a k-th power residue\n    return ()     if powmod($a, divint($phi, $g), $p) != 1;\n    return (1, 2) if $p == 3;\n\n    # Find one root and generate all others using roots of unity\n    my ($root, $gen) = _tonelli_shanks($a, $k, $p);\n    die \"Failed to find root\" if ($gen == 0 || powmod($root, $k, $p) != $a);\n\n    my @roots = ($root);\n    for (my $r = mulmod($root, $gen, $p) ; $r != $root && @roots < $k ; $r = mulmod($r, $gen, $p)) {\n        push @roots, $r;\n    }\n    return @roots;\n}\n\n#----------------------------------------------------------\n# Hensel lifting helpers\n#----------------------------------------------------------\nsub _hensel_lift_standard($roots, $A, $k, $mod) {\n    map {\n        my $deriv   = mulmod($k, powmod($_, $k - 1, $mod), $mod);\n        my $residue = submod($A, powmod($_, $k, $mod), $mod);\n        my $common  = gcd($residue, $deriv);\n        addmod($_, divmod(divint($residue, $common), divint($deriv, $common), $mod), $mod);\n    } @$roots;\n}\n\nsub _hensel_lift_singular($roots, $A, $k, $p, $mod) {\n    my $ext_mod = mulint($mod, $p);\n    my $submod  = divint($mod, $p);\n    my %seen;\n\n    for my $s (@$roots) {\n        my $deriv   = mulmod($k, powmod($s, $k - 1, $ext_mod), $ext_mod);\n        my $residue = submod($A, powmod($s, $k, $ext_mod), $ext_mod);\n        my $common  = gcd($residue, $deriv);\n        my $r       = addmod($s, divmod(divint($residue, $common), divint($deriv, $common), $mod), $mod);\n\n        next if powmod($r, $k, $mod) != $A % $mod;\n        $seen{mulmod($r, addmod(mulmod($_, $submod, $mod), 1, $mod), $mod)} = 1 for 0 .. $k - 1;\n    }\n    return keys %seen;\n}\n\n#----------------------------------------------------------\n# All k-th roots of r modulo prime power p^e\n#----------------------------------------------------------\nsub _roots_mod_prime_power($r, $k, $p, $e) {\n    return _roots_mod_prime($r, $k, $p) if $e == 1;\n\n    my $mod = powint($p, $e);\n    my $pk  = powint($p, $k);\n\n    # Special case:  a ≡ 0 (mod p^e)\n    if ($r % $mod == 0) {\n        my $t   = divint($e - 1, $k) + 1;\n        my $pt  = powint($p, $t);\n        my $cnt = powint($p, $e - $t);\n        return map { mulmod($_, $pt, $mod) } 0 .. $cnt - 1;\n    }\n\n    # Special case: a ≡ 0 (mod p^k) but a ≢ 0 (mod p^e)\n    if ($r % $pk == 0) {\n        my $factor = powint($p, $e - $k + 1);\n        my $count  = powint($p, $k - 1);\n        my @sub    = _roots_mod_prime_power(divint($r, $pk), $k, $p, $e - $k);\n        return map {\n            my $base = mulmod($_, $p, $mod);\n            map { addmod(mulmod($_, $factor, $mod), $base, $mod) } 0 .. $count - 1;\n        } @sub;\n    }\n\n    # No roots if p | a but p^k ∤ a\n    return () if $r % $p == 0;\n\n    # Hensel lifting from smaller exponent\n    my $half = ($p > 2 || $e < 5) ? divint($e + 1, 2) : divint($e + 3, 2);\n    my @sub  = _roots_mod_prime_power($r, $k, $p, $half);\n\n    return $k != $p\n      ? _hensel_lift_standard(\\@sub, $r, $k, $mod)\n      : _hensel_lift_singular(\\@sub, $r, $k, $p, $mod);\n}\n\n#----------------------------------------------------------\n# All k-th roots of r modulo n (with factorization)\n#----------------------------------------------------------\nsub _roots_mod_composite($r, $k, @factors) {\n    my ($mod, @roots) = (1);\n\n    for my $factor (@factors) {\n        my ($p, $e) = @$factor;\n        my @sub = _roots_mod_prime_power($r, $k, $p, $e);\n        return () unless @sub;\n\n        my $pe = powint($p, $e);\n        @roots = @roots ? _crt_combine(\\@roots, $mod, \\@sub, $pe) : @sub;\n        $mod   = mulint($mod, $pe);\n    }\n    return @roots;\n}\n\n#----------------------------------------------------------\n# Main entry point:  all k-th roots of A modulo n\n#----------------------------------------------------------\nsub kth_root_mod($k, $A, $n) {\n    $n = abs($n);\n    return () if $n == 0;\n\n    $A %= $n;\n    return () if $k <= 0 && $A == 0;\n\n    if ($k < 0) {\n        $A = invmod($A, $n) // return ();\n        return () if $A <= 0;\n        $k = -$k;\n    }\n\n    return ($A)                         if $n <= 2 || $k == 1;\n    return $A == 1 ? (0 .. $n - 1) : () if $k == 0;\n\n    my @factors = factor_exp($n);\n    my @roots   = ($A);\n\n    for my $prime_factor (factor($k)) {\n        @roots = map { _roots_mod_composite($_, $prime_factor, @factors) } @roots;\n    }\n\n    return sort { $a <=> $b } @roots;\n}\n\nis_deeply([kth_root_mod(3, 2, 101)], [26]);\nis_deeply([kth_root_mod(2, 0, 16)],  [0, 4, 8, 12]);\nis_deeply([kth_root_mod(2, 1, 101)], [1, 100]);\nis_deeply([kth_root_mod(5, 4320, 5040)],\n          [120, 330, 540, 750, 960, 1170, 1380, 1590, 1800, 2010, 2220, 2430, 2640, 2850, 3060, 3270, 3480, 3690, 3900, 4110, 4320, 4530, 4740, 4950]);\nis_deeply(\n          [kth_root_mod(6, 4320, 5040)],\n          [30,   60,   90,   120,  150,  180,  240,  270,  300,  330,  360,  390,  450,  480,  510,  540,  570,  600,  660,  690,  720,  750,  780,  810,\n           870,  900,  930,  960,  990,  1020, 1080, 1110, 1140, 1170, 1200, 1230, 1290, 1320, 1350, 1380, 1410, 1440, 1500, 1530, 1560, 1590, 1620, 1650,\n           1710, 1740, 1770, 1800, 1830, 1860, 1920, 1950, 1980, 2010, 2040, 2070, 2130, 2160, 2190, 2220, 2250, 2280, 2340, 2370, 2400, 2430, 2460, 2490,\n           2550, 2580, 2610, 2640, 2670, 2700, 2760, 2790, 2820, 2850, 2880, 2910, 2970, 3000, 3030, 3060, 3090, 3120, 3180, 3210, 3240, 3270, 3300, 3330,\n           3390, 3420, 3450, 3480, 3510, 3540, 3600, 3630, 3660, 3690, 3720, 3750, 3810, 3840, 3870, 3900, 3930, 3960, 4020, 4050, 4080, 4110, 4140, 4170,\n           4230, 4260, 4290, 4320, 4350, 4380, 4440, 4470, 4500, 4530, 4560, 4590, 4650, 4680, 4710, 4740, 4770, 4800, 4860, 4890, 4920, 4950, 4980, 5010\n          ]\n         );\nis_deeply(\n          [kth_root_mod(124, 2016, 5040)],\n          [42,   84,   126,  168,  252,  294,  336,  378,  462,  504,  546,  588,  672,  714,  756,  798,  882,  924,  966,  1008, 1092, 1134, 1176, 1218,\n           1302, 1344, 1386, 1428, 1512, 1554, 1596, 1638, 1722, 1764, 1806, 1848, 1932, 1974, 2016, 2058, 2142, 2184, 2226, 2268, 2352, 2394, 2436, 2478,\n           2562, 2604, 2646, 2688, 2772, 2814, 2856, 2898, 2982, 3024, 3066, 3108, 3192, 3234, 3276, 3318, 3402, 3444, 3486, 3528, 3612, 3654, 3696, 3738,\n           3822, 3864, 3906, 3948, 4032, 4074, 4116, 4158, 4242, 4284, 4326, 4368, 4452, 4494, 4536, 4578, 4662, 4704, 4746, 4788, 4872, 4914, 4956, 4998\n          ]\n         );\nis_deeply([kth_root_mod(5, 43,  5040)], [1723]);\nis_deeply([kth_root_mod(5, 243, 1000)], [3, 203, 403, 603, 803]);\nis_deeply(\n          [kth_root_mod(383, 32247425005, 64552988163)],\n          [49,          168545710,   337091371,   505637032,   674182693,   842728354,   1011274015,  1179819676,  1348365337,  1516910998,\n           1685456659,  1854002320,  2022547981,  2191093642,  2359639303,  2528184964,  2696730625,  2865276286,  3033821947,  3202367608,\n           3370913269,  3539458930,  3708004591,  3876550252,  4045095913,  4213641574,  4382187235,  4550732896,  4719278557,  4887824218,\n           5056369879,  5224915540,  5393461201,  5562006862,  5730552523,  5899098184,  6067643845,  6236189506,  6404735167,  6573280828,\n           6741826489,  6910372150,  7078917811,  7247463472,  7416009133,  7584554794,  7753100455,  7921646116,  8090191777,  8258737438,\n           8427283099,  8595828760,  8764374421,  8932920082,  9101465743,  9270011404,  9438557065,  9607102726,  9775648387,  9944194048,\n           10112739709, 10281285370, 10449831031, 10618376692, 10786922353, 10955468014, 11124013675, 11292559336, 11461104997, 11629650658,\n           11798196319, 11966741980, 12135287641, 12303833302, 12472378963, 12640924624, 12809470285, 12978015946, 13146561607, 13315107268,\n           13483652929, 13652198590, 13820744251, 13989289912, 14157835573, 14326381234, 14494926895, 14663472556, 14832018217, 15000563878,\n           15169109539, 15337655200, 15506200861, 15674746522, 15843292183, 16011837844, 16180383505, 16348929166, 16517474827, 16686020488,\n           16854566149, 17023111810, 17191657471, 17360203132, 17528748793, 17697294454, 17865840115, 18034385776, 18202931437, 18371477098,\n           18540022759, 18708568420, 18877114081, 19045659742, 19214205403, 19382751064, 19551296725, 19719842386, 19888388047, 20056933708,\n           20225479369, 20394025030, 20562570691, 20731116352, 20899662013, 21068207674, 21236753335, 21405298996, 21573844657, 21742390318,\n           21910935979, 22079481640, 22248027301, 22416572962, 22585118623, 22753664284, 22922209945, 23090755606, 23259301267, 23427846928,\n           23596392589, 23764938250, 23933483911, 24102029572, 24270575233, 24439120894, 24607666555, 24776212216, 24944757877, 25113303538,\n           25281849199, 25450394860, 25618940521, 25787486182, 25956031843, 26124577504, 26293123165, 26461668826, 26630214487, 26798760148,\n           26967305809, 27135851470, 27304397131, 27472942792, 27641488453, 27810034114, 27978579775, 28147125436, 28315671097, 28484216758,\n           28652762419, 28821308080, 28989853741, 29158399402, 29326945063, 29495490724, 29664036385, 29832582046, 30001127707, 30169673368,\n           30338219029, 30506764690, 30675310351, 30843856012, 31012401673, 31180947334, 31349492995, 31518038656, 31686584317, 31855129978,\n           32023675639, 32192221300, 32360766961, 32529312622, 32697858283, 32866403944, 33034949605, 33203495266, 33372040927, 33540586588,\n           33709132249, 33877677910, 34046223571, 34214769232, 34383314893, 34551860554, 34720406215, 34888951876, 35057497537, 35226043198,\n           35394588859, 35563134520, 35731680181, 35900225842, 36068771503, 36237317164, 36405862825, 36574408486, 36742954147, 36911499808,\n           37080045469, 37248591130, 37417136791, 37585682452, 37754228113, 37922773774, 38091319435, 38259865096, 38428410757, 38596956418,\n           38765502079, 38934047740, 39102593401, 39271139062, 39439684723, 39608230384, 39776776045, 39945321706, 40113867367, 40282413028,\n           40450958689, 40619504350, 40788050011, 40956595672, 41125141333, 41293686994, 41462232655, 41630778316, 41799323977, 41967869638,\n           42136415299, 42304960960, 42473506621, 42642052282, 42810597943, 42979143604, 43147689265, 43316234926, 43484780587, 43653326248,\n           43821871909, 43990417570, 44158963231, 44327508892, 44496054553, 44664600214, 44833145875, 45001691536, 45170237197, 45338782858,\n           45507328519, 45675874180, 45844419841, 46012965502, 46181511163, 46350056824, 46518602485, 46687148146, 46855693807, 47024239468,\n           47192785129, 47361330790, 47529876451, 47698422112, 47866967773, 48035513434, 48204059095, 48372604756, 48541150417, 48709696078,\n           48878241739, 49046787400, 49215333061, 49383878722, 49552424383, 49720970044, 49889515705, 50058061366, 50226607027, 50395152688,\n           50563698349, 50732244010, 50900789671, 51069335332, 51237880993, 51406426654, 51574972315, 51743517976, 51912063637, 52080609298,\n           52249154959, 52417700620, 52586246281, 52754791942, 52923337603, 53091883264, 53260428925, 53428974586, 53597520247, 53766065908,\n           53934611569, 54103157230, 54271702891, 54440248552, 54608794213, 54777339874, 54945885535, 55114431196, 55282976857, 55451522518,\n           55620068179, 55788613840, 55957159501, 56125705162, 56294250823, 56462796484, 56631342145, 56799887806, 56968433467, 57136979128,\n           57305524789, 57474070450, 57642616111, 57811161772, 57979707433, 58148253094, 58316798755, 58485344416, 58653890077, 58822435738,\n           58990981399, 59159527060, 59328072721, 59496618382, 59665164043, 59833709704, 60002255365, 60170801026, 60339346687, 60507892348,\n           60676438009, 60844983670, 61013529331, 61182074992, 61350620653, 61519166314, 61687711975, 61856257636, 62024803297, 62193348958,\n           62361894619, 62530440280, 62698985941, 62867531602, 63036077263, 63204622924, 63373168585, 63541714246, 63710259907, 63878805568,\n           64047351229, 64215896890, 64384442551\n          ]\n         );\n\nis_deeply(\n          [kth_root_mod(3432, 33, 10428581733134514527),],\n          [234538669356049904,  265172539733867379,  338494374696194946,  468144956219368759,   587920784072174975,   866212217277838851,\n           1191587698502237300, 1469879131707901176, 2012837926243083376, 2116793631583228418,  2246444213106402231,  2616504840673145701,\n           2819477257158647081, 2850111127536464556, 2969886955389270772, 3248178388594934648,  3672570580964689435,  3950862014170353311,\n           4095753547647065419, 4374044980852729295, 4597776514045680553, 4699420462077127744,  4977711895282791620,  5201443428475742878,\n           5227138304658771649, 5450869837851722907, 5729161271057386783, 5830805219088833974,  6054536752281785232,  6332828185487449108,\n           6477719718964161216, 6756011152169825092, 7180403344539579879, 7458694777745243755,  7578470605598049971,  7609104475975867446,\n           7812076892461368826, 8182137520028112296, 8311788101551286109, 8415743806891431151,  8958702601426613351,  9236994034632277227,\n           9562369515856675676, 9840660949062339552, 9960436776915145768, 10090087358438319581, 10163409193400647148, 10194043063778464623\n          ]\n         );\n\n# Check:\n#   p {prime, prime power, square-free composite, non-SF composite}\n#   k {prime, prime power, square-free composite, non-SF composite}\nmy @rootmods = (\n\n    # prime moduli\n    [14,    -3, 101,    [17]],\n    [13,     6, 107,    [24, 83]],\n    [13,    -6, 107,    [49, 58]],\n    [64,     6, 101,    [2,  99]],\n    [9,     -2, 101,    [34, 67]],\n    [2,      3, 3,      [2]],\n    [2,      3, 7,      undef],\n    [17,    29, 19,     [6]],\n    [5,      3, 13,     [7,     8,  11]],\n    [53,     3, 151,    [15,    27, 109]],\n    [3,      3, 73,     [25,    54, 67]],\n    [7,      3, 73,     [13,    29, 31]],\n    [49,     3, 73,     [12,    23, 38]],\n    [44082,  4, 100003, [2003,  98000]],\n    [90594,  6, 100019, [37071, 62948]],\n    [6,      5, 31,     [11,    13, 21, 22, 26]],\n    [0,      2, 2,      [0]],\n    [2,      4, 5,      undef],\n    [51,    12, 10009,  [64, 1203, 3183, 3247, 3999, 4807, 5202, 6010, 6762, 6826, 8806, 9945]],\n\n    #[15,3,1000000000000000000117,[qw/72574612502199260377 361680004182786118804 565745383315014620936/]],\n    [1,  0, 13, [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12]],\n    [2,  0, 13, undef],\n    [0,  5, 0,  undef],\n    [0, -1, 3,  undef],\n\n    # composite moduli.\n    # Pari will usually give a *wrong* answer for these if using Mod(a,p).\n    # The right way with Pari is to use p-adic.\n    [4,  2, 10,   [2, 8]],\n    [4,  2, 18,   [2, 16]],\n    [2,  3, 21,   undef],                                                # Pari says 2\n    [8,  3, 27,   [2,   11,  20]],                                       # Pari says 26\n    [22, 3, 1505, [148, 578, 673, 793, 813, 1103, 1243, 1318, 1458]],    # Pari says 1408\n    [58787, 3, 100035,\n     [3773,  8633,  10793, 13763, 19163, 24293, 26183, 26588, 31313, 37118, 41978, 44138, 47108, 52508,\n      57638, 59528, 59933, 64658, 70463, 75323, 77483, 80453, 85853, 90983, 92873, 93278, 98003\n     ]\n    ],\n    [3748, 2, 4992,\n     [154,  262,  314,  518,  730,  934,  986,  1094, 1402, 1510, 1562, 1766, 1978, 2182, 2234, 2342,\n      2650, 2758, 2810, 3014, 3226, 3430, 3482, 3590, 3898, 4006, 4058, 4262, 4474, 4678, 4730, 4838\n     ]\n    ],\n    [68,           2,  2048, [46,  466, 558, 978,  1070, 1490, 1582, 2002]],\n    [96,           5,  128,  [6,   14,  22,  30,   38,   46,   54,   62,   70,   78,   86,   94,   102,  110,  118,  126]],\n    [2912,         5,  4992, [182, 494, 806, 1118, 1430, 1742, 2054, 2366, 2678, 2990, 3302, 3614, 3926, 4238, 4550, 4862]],\n    [2,            3,  4,    undef],\n    [3,            2,  4,    undef],\n    [3,            4,  19,   undef],\n    [1,            4,  20,   [1, 3, 7,  9, 11, 13, 17, 19]],\n    [9,            2,  24,   [3, 9, 15, 21]],\n    [6,            6,  35,   undef],\n    [36,           2,  40,   [6, 14, 26, 34]],\n    [16,           12, 48,   [2, 4,  8,  10, 14, 16, 20, 22, 26, 28, 32, 34, 38, 40, 44, 46]],\n    [13,           6,  112,  undef],\n    [52,           6,  117,  undef],\n    [48,           3,  128,  undef],\n    [382,          3,  1000, undef],\n    [10,           3,  81,   [13, 40,  67]],\n    [26,           5,  625,  [81, 206, 331, 456, 581]],\n    [51,           5,  625,  [61, 186, 311, 436, 561]],\n    [\"9833625071\", 3,  \"10000000071\", [qw/3333332807 6666666164 9999999521/]],\n\n    #[2131968,5,10000000000, [...]],   # Far too many\n    [198, -1, 519, undef],\n);\n\nforeach my $t (@rootmods) {\n    say \"Testing: kth_root_mod($t->[1], $t->[0], $t->[2])\";\n    is_deeply([kth_root_mod($t->[1], $t->[0], $t->[2])], (defined($t->[3]) ? $t->[3] : []));\n}\n\n# ----- CLI usage -----\nif (@ARGV == 3) {\n    my ($k, $v, $m) = @ARGV;\n    my @sol = kth_root_mod($k, $v, $m);\n    if (!@sol) {\n        print \"No solution: x^$k ≡ $v (mod $m) has no solution.\\n\";\n    }\n    else {\n        print scalar(@sol),                        \" solution(s) mod $m:\\n\";\n        print join(\", \", sort { $a <=> $b } @sol), \"\\n\";\n    }\n    exit 0;\n}\n"
  },
  {
    "path": "Math/modular_k-th_root_all_solutions_fast_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# kth_root_mod: find all x (0 <= x < m) with x^k ≡ a (mod m)\n\n# Based on code from Math::Prime::Util::PP by Dana Jacobsen.\n\nuse 5.036;\nuse ntheory qw(:all);\nuse Math::GMPz;\nuse Test::More tests => 61;\n\n#----------------------------------------------------------\n# Tonelli-Shanks algorithm for k-th roots modulo a prime\n#----------------------------------------------------------\nsub _tonelli_shanks {\n    my ($a, $k, $p) = @_;\n\n    my $exp = 0;\n    my $q   = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_sub_ui($q, $p, 1);\n\n    while (Math::GMPz::Rmpz_divisible_p($q, $k)) {\n        $exp++;\n        Math::GMPz::Rmpz_divexact($q, $q, $k);\n    }\n\n    my $k_exp = Math::GMPz::Rmpz_init();\n    my $tmp   = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_sub_ui($tmp, $p, 1);\n    Math::GMPz::Rmpz_divexact($k_exp, $tmp, $q);\n\n    my $inv_k   = Math::GMPz::Rmpz_init();\n    my $k_mod_q = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_mod($k_mod_q, $k, $q);\n    Math::GMPz::Rmpz_invert($inv_k, $k_mod_q, $q);\n\n    my $root = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_powm($root, $a, $inv_k, $p);\n\n    my $root_k = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_powm($root_k, $root, $k, $p);\n\n    my $inv_a = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_invert($inv_a, $a, $p);\n\n    my $b = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_mul($b, $root_k, $inv_a);\n    Math::GMPz::Rmpz_mod($b, $b, $p);\n\n    # Find a generator of the k-th roots of unity\n    my $candidate   = Math::GMPz::Rmpz_init_set_ui(2);\n    my $zeta        = Math::GMPz::Rmpz_init_set_ui(1);\n    my $gen         = Math::GMPz::Rmpz_init();\n    my $k_exp_div_k = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_divexact($k_exp_div_k, $k_exp, $k);\n\n    while (Math::GMPz::Rmpz_cmp_ui($zeta, 1) == 0) {\n        Math::GMPz::Rmpz_powm($gen,  $candidate, $q,           $p);\n        Math::GMPz::Rmpz_powm($zeta, $gen,       $k_exp_div_k, $p);\n        Math::GMPz::Rmpz_add_ui($candidate, $candidate, 1);\n    }\n\n    # Iteratively refine the root\n    my $new_gen           = Math::GMPz::Rmpz_init();\n    my $k_exp_div_k_inner = Math::GMPz::Rmpz_init();\n    my $test              = Math::GMPz::Rmpz_init();\n\n    while (Math::GMPz::Rmpz_cmp($k_exp, $k) != 0) {\n        Math::GMPz::Rmpz_divexact($k_exp, $k_exp, $k);\n\n        Math::GMPz::Rmpz_powm($new_gen, $gen, $k, $p);\n        Math::GMPz::Rmpz_set($candidate, $gen);\n        Math::GMPz::Rmpz_set($gen,       $new_gen);\n\n        Math::GMPz::Rmpz_divexact($k_exp_div_k_inner, $k_exp, $k);\n        Math::GMPz::Rmpz_powm($test, $b, $k_exp_div_k_inner, $p);\n\n        while (Math::GMPz::Rmpz_cmp_ui($test, 1) != 0) {\n            Math::GMPz::Rmpz_mul($root, $root, $candidate);\n            Math::GMPz::Rmpz_mod($root, $root, $p);\n\n            Math::GMPz::Rmpz_mul($b, $b, $gen);\n            Math::GMPz::Rmpz_mod($b, $b, $p);\n\n            Math::GMPz::Rmpz_mul($test, $test, $zeta);\n            Math::GMPz::Rmpz_mod($test, $test, $p);\n        }\n    }\n\n    return ($root, $gen);    # return both root and zeta (gen)\n}\n\n#----------------------------------------------------------\n# Chinese Remainder Theorem:   combine roots from two moduli\n#----------------------------------------------------------\nsub _crt_combine {\n    my ($roots_a, $mod_a, $roots_b, $mod_b) = @_;\n\n    state $mod = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_mul($mod, $mod_a, $mod_b);\n\n    state $inv = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_invert($inv, $mod_a, $mod_b)\n      or die \"CRT: undefined inverse\";\n\n    my @roots;\n    state $diff   = Math::GMPz::Rmpz_init();\n    state $result = Math::GMPz::Rmpz_init();\n\n    for my $ra (@$roots_a) {\n        for my $rb (@$roots_b) {\n            Math::GMPz::Rmpz_sub($diff, $rb, $ra);\n            Math::GMPz::Rmpz_mul($diff, $diff, $inv);\n            Math::GMPz::Rmpz_mod($diff, $diff, $mod_b);\n\n            Math::GMPz::Rmpz_mul($result, $mod_a, $diff);\n            Math::GMPz::Rmpz_add($result, $result, $ra);\n            Math::GMPz::Rmpz_mod($result, $result, $mod);\n\n            push @roots, Math::GMPz::Rmpz_init_set($result);\n        }\n    }\n\n    return \\@roots;\n}\n\n#----------------------------------------------------------\n# All k-th roots of a modulo prime p\n#----------------------------------------------------------\nsub _roots_mod_prime {\n    my ($a, $k, $p) = @_;\n\n    state $a_mod = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_mod($a_mod, $a, $p);\n\n    if (Math::GMPz::Rmpz_cmp_ui($p, 2) == 0 || Math::GMPz::Rmpz_cmp_ui($a_mod, 0) == 0) {\n        return [Math::GMPz::Rmpz_init_set($a_mod)];\n    }\n\n    state $phi = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_sub_ui($phi, $p, 1);\n\n    state $g = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_gcd($g, $k, $phi);\n\n    # Unique root when gcd(k, p-1) = 1\n    if (Math::GMPz::Rmpz_cmp_ui($g, 1) == 0) {\n        my $k_mod_phi = Math::GMPz::Rmpz_init();\n        Math::GMPz::Rmpz_mod($k_mod_phi, $k, $phi);\n        my $inv = Math::GMPz::Rmpz_init();\n        Math::GMPz::Rmpz_invert($inv, $k_mod_phi, $phi);\n        my $root = Math::GMPz::Rmpz_init();\n        Math::GMPz::Rmpz_powm($root, $a_mod, $inv, $p);\n        return [$root];\n    }\n\n    # No roots if a is not a k-th power residue\n    state $phi_div_g = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_divexact($phi_div_g, $phi, $g);\n    state $test = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_powm($test, $a_mod, $phi_div_g, $p);\n    return [] if (Math::GMPz::Rmpz_cmp_ui($test, 1) != 0);\n\n    if (Math::GMPz::Rmpz_cmp_ui($p, 3) == 0) {\n        return [Math::GMPz::Rmpz_init_set_ui(1), Math::GMPz::Rmpz_init_set_ui(2)];\n    }\n\n    # Find one root and generate all others using roots of unity\n    my ($root, $zeta) = _tonelli_shanks($a_mod, $k, $p);\n\n    if (Math::GMPz::Rmpz_cmp_ui($zeta, 0) == 0) {\n        die \"Failed to find root\";\n    }\n    state $root_k = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_powm($root_k, $root, $k, $p);\n    if (Math::GMPz::Rmpz_cmp($root_k, $a_mod) != 0) {\n        die \"Failed to find root\";\n    }\n\n    my @roots = (Math::GMPz::Rmpz_init_set($root));\n    my $r     = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_mul($r, $root, $zeta);\n    Math::GMPz::Rmpz_mod($r, $r, $p);\n\n    my $k_ui = Math::GMPz::Rmpz_get_ui($k);\n\n    while (Math::GMPz::Rmpz_cmp($r, $root) != 0 && scalar(@roots) < $k_ui) {\n        push @roots, Math::GMPz::Rmpz_init_set($r);\n        Math::GMPz::Rmpz_mul($r, $r, $zeta);\n        Math::GMPz::Rmpz_mod($r, $r, $p);\n    }\n\n    return \\@roots;\n}\n\n#----------------------------------------------------------\n# Hensel lifting helpers\n#----------------------------------------------------------\nsub _hensel_lift_standard {\n    my ($roots, $A, $k, $mod) = @_;\n\n    my @result;\n\n    state $k_minus_1 = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_sub_ui($k_minus_1, $k, 1);\n\n    state $s_pow     = Math::GMPz::Rmpz_init();\n    state $deriv     = Math::GMPz::Rmpz_init();\n    state $s_k       = Math::GMPz::Rmpz_init();\n    state $residue   = Math::GMPz::Rmpz_init();\n    state $common    = Math::GMPz::Rmpz_init();\n    state $res_div   = Math::GMPz::Rmpz_init();\n    state $deriv_div = Math::GMPz::Rmpz_init();\n    state $inv_deriv = Math::GMPz::Rmpz_init();\n    state $quot      = Math::GMPz::Rmpz_init();\n    state $new_s     = Math::GMPz::Rmpz_init();\n\n    for my $s (@$roots) {\n        Math::GMPz::Rmpz_powm($s_pow, $s, $k_minus_1, $mod);\n\n        Math::GMPz::Rmpz_mul($deriv, $k, $s_pow);\n        Math::GMPz::Rmpz_mod($deriv, $deriv, $mod);\n\n        Math::GMPz::Rmpz_powm($s_k, $s, $k, $mod);\n\n        Math::GMPz::Rmpz_sub($residue, $A, $s_k);\n        Math::GMPz::Rmpz_mod($residue, $residue, $mod);\n        Math::GMPz::Rmpz_gcd($common, $residue, $deriv);\n\n        Math::GMPz::Rmpz_divexact($res_div,   $residue, $common);\n        Math::GMPz::Rmpz_divexact($deriv_div, $deriv,   $common);\n\n        Math::GMPz::Rmpz_invert($inv_deriv, $deriv_div, $mod);\n\n        Math::GMPz::Rmpz_mul($quot, $res_div, $inv_deriv);\n        Math::GMPz::Rmpz_mod($quot, $quot, $mod);\n\n        Math::GMPz::Rmpz_add($new_s, $s, $quot);\n        Math::GMPz::Rmpz_mod($new_s, $new_s, $mod);\n\n        push @result, Math::GMPz::Rmpz_init_set($new_s);\n    }\n    return \\@result;\n}\n\nsub _hensel_lift_singular {\n    my ($roots, $A, $k, $p, $mod) = @_;\n\n    state $ext_mod = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_mul($ext_mod, $mod, $p);\n\n    state $submod_val = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_divexact($submod_val, $mod, $p);\n\n    my %seen;\n\n    state $k_minus_1 = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_sub_ui($k_minus_1, $k, 1);\n\n    state $s_pow     = Math::GMPz::Rmpz_init();\n    state $deriv     = Math::GMPz::Rmpz_init();\n    state $s_k       = Math::GMPz::Rmpz_init();\n    state $residue   = Math::GMPz::Rmpz_init();\n    state $common    = Math::GMPz::Rmpz_init();\n    state $res_div   = Math::GMPz::Rmpz_init();\n    state $deriv_div = Math::GMPz::Rmpz_init();\n    state $inv_deriv = Math::GMPz::Rmpz_init();\n    state $quot      = Math::GMPz::Rmpz_init();\n    state $r         = Math::GMPz::Rmpz_init();\n    state $r_k       = Math::GMPz::Rmpz_init();\n    state $A_mod     = Math::GMPz::Rmpz_init();\n    state $i_val     = Math::GMPz::Rmpz_init();\n    state $new_r     = Math::GMPz::Rmpz_init();\n\n    my $k_ui = Math::GMPz::Rmpz_get_ui($k);\n\n    for my $s (@$roots) {\n        Math::GMPz::Rmpz_powm($s_pow, $s, $k_minus_1, $ext_mod);\n\n        Math::GMPz::Rmpz_mul($deriv, $k, $s_pow);\n        Math::GMPz::Rmpz_mod($deriv, $deriv, $ext_mod);\n        Math::GMPz::Rmpz_powm($s_k, $s, $k, $ext_mod);\n\n        Math::GMPz::Rmpz_sub($residue, $A, $s_k);\n        Math::GMPz::Rmpz_mod($residue, $residue, $ext_mod);\n        Math::GMPz::Rmpz_gcd($common, $residue, $deriv);\n\n        Math::GMPz::Rmpz_divexact($res_div,   $residue, $common);\n        Math::GMPz::Rmpz_divexact($deriv_div, $deriv,   $common);\n\n        Math::GMPz::Rmpz_invert($inv_deriv, $deriv_div, $mod);\n\n        Math::GMPz::Rmpz_mul($quot, $res_div, $inv_deriv);\n        Math::GMPz::Rmpz_mod($quot, $quot, $mod);\n\n        Math::GMPz::Rmpz_add($r, $s, $quot);\n        Math::GMPz::Rmpz_mod($r, $r, $mod);\n\n        Math::GMPz::Rmpz_powm($r_k, $r, $k, $mod);\n\n        Math::GMPz::Rmpz_mod($A_mod, $A, $mod);\n        next if (Math::GMPz::Rmpz_cmp($r_k, $A_mod) != 0);\n\n        for my $i (0 .. $k_ui - 1) {\n            Math::GMPz::Rmpz_mul_ui($i_val, $submod_val, $i);\n            Math::GMPz::Rmpz_mod($i_val, $i_val, $mod);\n            Math::GMPz::Rmpz_add_ui($i_val, $i_val, 1);\n            Math::GMPz::Rmpz_mod($i_val, $i_val, $mod);\n\n            Math::GMPz::Rmpz_mul($new_r, $r, $i_val);\n            Math::GMPz::Rmpz_mod($new_r, $new_r, $mod);\n\n            $seen{Math::GMPz::Rmpz_get_str($new_r, 10)} = Math::GMPz::Rmpz_init_set($new_r);\n        }\n    }\n    return [values %seen];\n}\n\n#----------------------------------------------------------\n# All k-th roots of r modulo prime power p^e\n#----------------------------------------------------------\nsub _roots_mod_prime_power {\n    my ($r, $k, $p, $e) = @_;\n\n    return _roots_mod_prime($r, $k, $p) if ($e == 1);\n\n    my $mod = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_pow_ui($mod, $p, $e);\n\n    my $k_ui = Math::GMPz::Rmpz_get_ui($k);\n    my $pk   = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_pow_ui($pk, $p, $k_ui);\n\n    # Special case:   a ≡ 0 (mod p^e)\n    my $r_mod = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_mod($r_mod, $r, $mod);\n    if (Math::GMPz::Rmpz_cmp_ui($r_mod, 0) == 0) {\n        my $t  = int(($e - 1) / $k_ui) + 1;\n        my $pt = Math::GMPz::Rmpz_init();\n        Math::GMPz::Rmpz_pow_ui($pt, $p, $t);\n        my $cnt = Math::GMPz::Rmpz_init();\n        Math::GMPz::Rmpz_pow_ui($cnt, $p, $e - $t);\n        my $cnt_ui = Math::GMPz::Rmpz_get_ui($cnt);\n\n        my @result;\n        my $val = Math::GMPz::Rmpz_init();\n        for my $i (0 .. $cnt_ui - 1) {\n            Math::GMPz::Rmpz_mul_ui($val, $pt, $i);\n            Math::GMPz::Rmpz_mod($val, $val, $mod);\n            push @result, Math::GMPz::Rmpz_init_set($val);\n        }\n        return \\@result;\n    }\n\n    # Special case:  a ≡ 0 (mod p^k) but a ≢ 0 (mod p^e)\n    my $r_mod_pk = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_mod($r_mod_pk, $r, $pk);\n    if (Math::GMPz::Rmpz_cmp_ui($r_mod_pk, 0) == 0) {\n\n        my $factor = Math::GMPz::Rmpz_init();\n        Math::GMPz::Rmpz_pow_ui($factor, $p, ($e - $k_ui) + 1);\n\n        my $count = Math::GMPz::Rmpz_init();\n        Math::GMPz::Rmpz_pow_ui($count, $p, $k_ui - 1);\n\n        my $count_ui = Math::GMPz::Rmpz_get_ui($count);\n        my $r_div_pk = Math::GMPz::Rmpz_init();\n        Math::GMPz::Rmpz_divexact($r_div_pk, $r, $pk);\n\n        my $sub = _roots_mod_prime_power($r_div_pk, $k, $p, $e - $k_ui);\n\n        my @result;\n        my $base = Math::GMPz::Rmpz_init();\n        my $val  = Math::GMPz::Rmpz_init();\n\n        for my $s (@$sub) {\n            Math::GMPz::Rmpz_mul($base, $s, $p);\n            Math::GMPz::Rmpz_mod($base, $base, $mod);\n\n            for my $i (0 .. $count_ui - 1) {\n                Math::GMPz::Rmpz_mul_ui($val, $factor, $i);\n                Math::GMPz::Rmpz_add($val, $val, $base);\n                Math::GMPz::Rmpz_mod($val, $val, $mod);\n                push @result, Math::GMPz::Rmpz_init_set($val);\n            }\n        }\n        return \\@result;\n    }\n\n    # No roots if p | a but p^k ∤ a\n    my $r_mod_p = Math::GMPz::Rmpz_init();\n    Math::GMPz::Rmpz_mod($r_mod_p, $r, $p);\n    return [] if (Math::GMPz::Rmpz_cmp_ui($r_mod_p, 0) == 0);\n\n    # Hensel lifting from smaller exponent\n    my $half =\n      (Math::GMPz::Rmpz_cmp_ui($p, 2) > 0 || $e < 5)\n      ? int(($e + 1) / 2)\n      : int(($e + 3) / 2);\n\n    my $sub = _roots_mod_prime_power($r, $k, $p, $half);\n\n    if (Math::GMPz::Rmpz_cmp($k, $p) != 0) {\n        return _hensel_lift_standard($sub, $r, $k, $mod);\n    }\n    else {\n        return _hensel_lift_singular($sub, $r, $k, $p, $mod);\n    }\n}\n\n#----------------------------------------------------------\n# All k-th roots of r modulo n (with factorization)\n#----------------------------------------------------------\nsub _roots_mod_composite {\n    my ($r, $k, $factors) = @_;\n\n    my $mod   = Math::GMPz::Rmpz_init_set_ui(1);\n    my $roots = [];\n    my $pe    = Math::GMPz::Rmpz_init();\n\n    for my $factor (@$factors) {\n        my ($p, $e) = @$factor;\n\n        my $sub = _roots_mod_prime_power($r, $k, $p, $e);\n        return [] if (!@$sub);\n\n        Math::GMPz::Rmpz_pow_ui($pe, $p, $e);\n\n        if (@$roots) {\n            $roots = _crt_combine($roots, $mod, $sub, $pe);\n        }\n        else {\n            $roots = $sub;\n        }\n        Math::GMPz::Rmpz_mul($mod, $mod, $pe);\n    }\n    return $roots;\n}\n\n#----------------------------------------------------------\n# Main entry point:   all k-th roots of A modulo n\n#----------------------------------------------------------\nsub kth_root_mod {\n    my ($k, $A, $n) = @_;\n\n    $k = Math::GMPz->new($k);\n    $A = Math::GMPz->new($A);\n    $n = Math::GMPz->new($n);\n\n    Math::GMPz::Rmpz_abs($n, $n);\n    return () if (Math::GMPz::Rmpz_cmp_ui($n, 0) == 0);\n\n    Math::GMPz::Rmpz_mod($A, $A, $n);\n\n    if (Math::GMPz::Rmpz_cmp_ui($k, 0) <= 0 && Math::GMPz::Rmpz_cmp_ui($A, 0) == 0) {\n        return ();\n    }\n\n    if (Math::GMPz::Rmpz_sgn($k) < 0) {\n        my $inv = Math::GMPz::Rmpz_init();\n        if (!Math::GMPz::Rmpz_invert($inv, $A, $n)) {\n            return ();\n        }\n        my $g = Math::GMPz::Rmpz_init();\n        Math::GMPz::Rmpz_gcd($g, $inv, $n);\n        return () if (Math::GMPz::Rmpz_cmp_ui($g, 1) != 0);\n        Math::GMPz::Rmpz_set($A, $inv);\n        Math::GMPz::Rmpz_neg($k, $k);\n    }\n\n    if (Math::GMPz::Rmpz_cmp_ui($n, 2) <= 0 || Math::GMPz::Rmpz_cmp_ui($k, 1) == 0) {\n        return (Math::GMPz::Rmpz_init_set($A));\n    }\n\n    if (Math::GMPz::Rmpz_cmp_ui($k, 0) == 0) {\n        if (Math::GMPz::Rmpz_cmp_ui($A, 1) == 0) {\n            my $n_ui = Math::GMPz::Rmpz_get_ui($n);\n            return (0 .. $n_ui - 1);\n        }\n        return ();\n    }\n\n    my @factors = map { [Math::GMPz->new($_->[0]), $_->[1]] } factor_exp(Math::GMPz::Rmpz_get_str($n, 10));\n\n    my $roots     = [Math::GMPz::Rmpz_init_set($A)];\n    my @k_factors = map { Math::GMPz->new($_) } factor(Math::GMPz::Rmpz_get_str($k, 10));\n\n    for my $prime_factor (@k_factors) {\n        my @new_roots;\n        for my $r (@$roots) {\n            my $sub = _roots_mod_composite($r, $prime_factor, \\@factors);\n            push @new_roots, @$sub;\n        }\n        $roots = \\@new_roots;\n    }\n\n    return sort { Math::GMPz::Rmpz_cmp($a, $b) } @$roots;\n}\n\nis_deeply([kth_root_mod(3, 2, 101)], [26]);\nis_deeply([kth_root_mod(2, 0, 16)],  [0, 4, 8, 12]);\nis_deeply([kth_root_mod(2, 1, 101)], [1, 100]);\nis_deeply([kth_root_mod(5, 4320, 5040)],\n          [120, 330, 540, 750, 960, 1170, 1380, 1590, 1800, 2010, 2220, 2430, 2640, 2850, 3060, 3270, 3480, 3690, 3900, 4110, 4320, 4530, 4740, 4950]);\nis_deeply(\n          [kth_root_mod(6, 4320, 5040)],\n          [30,   60,   90,   120,  150,  180,  240,  270,  300,  330,  360,  390,  450,  480,  510,  540,  570,  600,  660,  690,  720,  750,  780,  810,\n           870,  900,  930,  960,  990,  1020, 1080, 1110, 1140, 1170, 1200, 1230, 1290, 1320, 1350, 1380, 1410, 1440, 1500, 1530, 1560, 1590, 1620, 1650,\n           1710, 1740, 1770, 1800, 1830, 1860, 1920, 1950, 1980, 2010, 2040, 2070, 2130, 2160, 2190, 2220, 2250, 2280, 2340, 2370, 2400, 2430, 2460, 2490,\n           2550, 2580, 2610, 2640, 2670, 2700, 2760, 2790, 2820, 2850, 2880, 2910, 2970, 3000, 3030, 3060, 3090, 3120, 3180, 3210, 3240, 3270, 3300, 3330,\n           3390, 3420, 3450, 3480, 3510, 3540, 3600, 3630, 3660, 3690, 3720, 3750, 3810, 3840, 3870, 3900, 3930, 3960, 4020, 4050, 4080, 4110, 4140, 4170,\n           4230, 4260, 4290, 4320, 4350, 4380, 4440, 4470, 4500, 4530, 4560, 4590, 4650, 4680, 4710, 4740, 4770, 4800, 4860, 4890, 4920, 4950, 4980, 5010\n          ]\n         );\nis_deeply(\n          [kth_root_mod(124, 2016, 5040)],\n          [42,   84,   126,  168,  252,  294,  336,  378,  462,  504,  546,  588,  672,  714,  756,  798,  882,  924,  966,  1008, 1092, 1134, 1176, 1218,\n           1302, 1344, 1386, 1428, 1512, 1554, 1596, 1638, 1722, 1764, 1806, 1848, 1932, 1974, 2016, 2058, 2142, 2184, 2226, 2268, 2352, 2394, 2436, 2478,\n           2562, 2604, 2646, 2688, 2772, 2814, 2856, 2898, 2982, 3024, 3066, 3108, 3192, 3234, 3276, 3318, 3402, 3444, 3486, 3528, 3612, 3654, 3696, 3738,\n           3822, 3864, 3906, 3948, 4032, 4074, 4116, 4158, 4242, 4284, 4326, 4368, 4452, 4494, 4536, 4578, 4662, 4704, 4746, 4788, 4872, 4914, 4956, 4998\n          ]\n         );\nis_deeply([kth_root_mod(5, 43,  5040)], [1723]);\nis_deeply([kth_root_mod(5, 243, 1000)], [3, 203, 403, 603, 803]);\nis_deeply(\n          [kth_root_mod(383, 32247425005, 64552988163)],\n          [49,          168545710,   337091371,   505637032,   674182693,   842728354,   1011274015,  1179819676,  1348365337,  1516910998,\n           1685456659,  1854002320,  2022547981,  2191093642,  2359639303,  2528184964,  2696730625,  2865276286,  3033821947,  3202367608,\n           3370913269,  3539458930,  3708004591,  3876550252,  4045095913,  4213641574,  4382187235,  4550732896,  4719278557,  4887824218,\n           5056369879,  5224915540,  5393461201,  5562006862,  5730552523,  5899098184,  6067643845,  6236189506,  6404735167,  6573280828,\n           6741826489,  6910372150,  7078917811,  7247463472,  7416009133,  7584554794,  7753100455,  7921646116,  8090191777,  8258737438,\n           8427283099,  8595828760,  8764374421,  8932920082,  9101465743,  9270011404,  9438557065,  9607102726,  9775648387,  9944194048,\n           10112739709, 10281285370, 10449831031, 10618376692, 10786922353, 10955468014, 11124013675, 11292559336, 11461104997, 11629650658,\n           11798196319, 11966741980, 12135287641, 12303833302, 12472378963, 12640924624, 12809470285, 12978015946, 13146561607, 13315107268,\n           13483652929, 13652198590, 13820744251, 13989289912, 14157835573, 14326381234, 14494926895, 14663472556, 14832018217, 15000563878,\n           15169109539, 15337655200, 15506200861, 15674746522, 15843292183, 16011837844, 16180383505, 16348929166, 16517474827, 16686020488,\n           16854566149, 17023111810, 17191657471, 17360203132, 17528748793, 17697294454, 17865840115, 18034385776, 18202931437, 18371477098,\n           18540022759, 18708568420, 18877114081, 19045659742, 19214205403, 19382751064, 19551296725, 19719842386, 19888388047, 20056933708,\n           20225479369, 20394025030, 20562570691, 20731116352, 20899662013, 21068207674, 21236753335, 21405298996, 21573844657, 21742390318,\n           21910935979, 22079481640, 22248027301, 22416572962, 22585118623, 22753664284, 22922209945, 23090755606, 23259301267, 23427846928,\n           23596392589, 23764938250, 23933483911, 24102029572, 24270575233, 24439120894, 24607666555, 24776212216, 24944757877, 25113303538,\n           25281849199, 25450394860, 25618940521, 25787486182, 25956031843, 26124577504, 26293123165, 26461668826, 26630214487, 26798760148,\n           26967305809, 27135851470, 27304397131, 27472942792, 27641488453, 27810034114, 27978579775, 28147125436, 28315671097, 28484216758,\n           28652762419, 28821308080, 28989853741, 29158399402, 29326945063, 29495490724, 29664036385, 29832582046, 30001127707, 30169673368,\n           30338219029, 30506764690, 30675310351, 30843856012, 31012401673, 31180947334, 31349492995, 31518038656, 31686584317, 31855129978,\n           32023675639, 32192221300, 32360766961, 32529312622, 32697858283, 32866403944, 33034949605, 33203495266, 33372040927, 33540586588,\n           33709132249, 33877677910, 34046223571, 34214769232, 34383314893, 34551860554, 34720406215, 34888951876, 35057497537, 35226043198,\n           35394588859, 35563134520, 35731680181, 35900225842, 36068771503, 36237317164, 36405862825, 36574408486, 36742954147, 36911499808,\n           37080045469, 37248591130, 37417136791, 37585682452, 37754228113, 37922773774, 38091319435, 38259865096, 38428410757, 38596956418,\n           38765502079, 38934047740, 39102593401, 39271139062, 39439684723, 39608230384, 39776776045, 39945321706, 40113867367, 40282413028,\n           40450958689, 40619504350, 40788050011, 40956595672, 41125141333, 41293686994, 41462232655, 41630778316, 41799323977, 41967869638,\n           42136415299, 42304960960, 42473506621, 42642052282, 42810597943, 42979143604, 43147689265, 43316234926, 43484780587, 43653326248,\n           43821871909, 43990417570, 44158963231, 44327508892, 44496054553, 44664600214, 44833145875, 45001691536, 45170237197, 45338782858,\n           45507328519, 45675874180, 45844419841, 46012965502, 46181511163, 46350056824, 46518602485, 46687148146, 46855693807, 47024239468,\n           47192785129, 47361330790, 47529876451, 47698422112, 47866967773, 48035513434, 48204059095, 48372604756, 48541150417, 48709696078,\n           48878241739, 49046787400, 49215333061, 49383878722, 49552424383, 49720970044, 49889515705, 50058061366, 50226607027, 50395152688,\n           50563698349, 50732244010, 50900789671, 51069335332, 51237880993, 51406426654, 51574972315, 51743517976, 51912063637, 52080609298,\n           52249154959, 52417700620, 52586246281, 52754791942, 52923337603, 53091883264, 53260428925, 53428974586, 53597520247, 53766065908,\n           53934611569, 54103157230, 54271702891, 54440248552, 54608794213, 54777339874, 54945885535, 55114431196, 55282976857, 55451522518,\n           55620068179, 55788613840, 55957159501, 56125705162, 56294250823, 56462796484, 56631342145, 56799887806, 56968433467, 57136979128,\n           57305524789, 57474070450, 57642616111, 57811161772, 57979707433, 58148253094, 58316798755, 58485344416, 58653890077, 58822435738,\n           58990981399, 59159527060, 59328072721, 59496618382, 59665164043, 59833709704, 60002255365, 60170801026, 60339346687, 60507892348,\n           60676438009, 60844983670, 61013529331, 61182074992, 61350620653, 61519166314, 61687711975, 61856257636, 62024803297, 62193348958,\n           62361894619, 62530440280, 62698985941, 62867531602, 63036077263, 63204622924, 63373168585, 63541714246, 63710259907, 63878805568,\n           64047351229, 64215896890, 64384442551\n          ]\n         );\n\nis_deeply(\n          [kth_root_mod(3432, 33, 10428581733134514527),],\n          [234538669356049904,  265172539733867379,  338494374696194946,  468144956219368759,   587920784072174975,   866212217277838851,\n           1191587698502237300, 1469879131707901176, 2012837926243083376, 2116793631583228418,  2246444213106402231,  2616504840673145701,\n           2819477257158647081, 2850111127536464556, 2969886955389270772, 3248178388594934648,  3672570580964689435,  3950862014170353311,\n           4095753547647065419, 4374044980852729295, 4597776514045680553, 4699420462077127744,  4977711895282791620,  5201443428475742878,\n           5227138304658771649, 5450869837851722907, 5729161271057386783, 5830805219088833974,  6054536752281785232,  6332828185487449108,\n           6477719718964161216, 6756011152169825092, 7180403344539579879, 7458694777745243755,  7578470605598049971,  7609104475975867446,\n           7812076892461368826, 8182137520028112296, 8311788101551286109, 8415743806891431151,  8958702601426613351,  9236994034632277227,\n           9562369515856675676, 9840660949062339552, 9960436776915145768, 10090087358438319581, 10163409193400647148, 10194043063778464623\n          ]\n         );\n\n# Check:\n#   p {prime, prime power, square-free composite, non-SF composite}\n#   k {prime, prime power, square-free composite, non-SF composite}\nmy @rootmods = (\n\n    # prime moduli\n    [14,    -3, 101,    [17]],\n    [13,     6, 107,    [24, 83]],\n    [13,    -6, 107,    [49, 58]],\n    [64,     6, 101,    [2,  99]],\n    [9,     -2, 101,    [34, 67]],\n    [2,      3, 3,      [2]],\n    [2,      3, 7,      undef],\n    [17,    29, 19,     [6]],\n    [5,      3, 13,     [7,     8,  11]],\n    [53,     3, 151,    [15,    27, 109]],\n    [3,      3, 73,     [25,    54, 67]],\n    [7,      3, 73,     [13,    29, 31]],\n    [49,     3, 73,     [12,    23, 38]],\n    [44082,  4, 100003, [2003,  98000]],\n    [90594,  6, 100019, [37071, 62948]],\n    [6,      5, 31,     [11,    13, 21, 22, 26]],\n    [0,      2, 2,      [0]],\n    [2,      4, 5,      undef],\n    [51,    12, 10009,  [64, 1203, 3183, 3247, 3999, 4807, 5202, 6010, 6762, 6826, 8806, 9945]],\n\n    [15,  3, Math::GMPz->new(\"1000000000000000000117\"), [qw/72574612502199260377 361680004182786118804 565745383315014620936/]],\n    [1,   0, 13,                                        [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12]],\n    [2,   0, 13,                                        undef],\n    [0,   5, 0,                                         undef],\n    [0,  -1, 3,                                         undef],\n\n    # composite moduli.\n    # Pari will usually give a *wrong* answer for these if using Mod(a,p).\n    # The right way with Pari is to use p-adic.\n    [4,  2, 10,   [2, 8]],\n    [4,  2, 18,   [2, 16]],\n    [2,  3, 21,   undef],                                                # Pari says 2\n    [8,  3, 27,   [2,   11,  20]],                                       # Pari says 26\n    [22, 3, 1505, [148, 578, 673, 793, 813, 1103, 1243, 1318, 1458]],    # Pari says 1408\n    [58787, 3, 100035,\n     [3773,  8633,  10793, 13763, 19163, 24293, 26183, 26588, 31313, 37118, 41978, 44138, 47108, 52508,\n      57638, 59528, 59933, 64658, 70463, 75323, 77483, 80453, 85853, 90983, 92873, 93278, 98003\n     ]\n    ],\n    [3748, 2, 4992,\n     [154,  262,  314,  518,  730,  934,  986,  1094, 1402, 1510, 1562, 1766, 1978, 2182, 2234, 2342,\n      2650, 2758, 2810, 3014, 3226, 3430, 3482, 3590, 3898, 4006, 4058, 4262, 4474, 4678, 4730, 4838\n     ]\n    ],\n    [68,           2,  2048, [46,  466, 558, 978,  1070, 1490, 1582, 2002]],\n    [96,           5,  128,  [6,   14,  22,  30,   38,   46,   54,   62,   70,   78,   86,   94,   102,  110,  118,  126]],\n    [2912,         5,  4992, [182, 494, 806, 1118, 1430, 1742, 2054, 2366, 2678, 2990, 3302, 3614, 3926, 4238, 4550, 4862]],\n    [2,            3,  4,    undef],\n    [3,            2,  4,    undef],\n    [3,            4,  19,   undef],\n    [1,            4,  20,   [1, 3, 7,  9, 11, 13, 17, 19]],\n    [9,            2,  24,   [3, 9, 15, 21]],\n    [6,            6,  35,   undef],\n    [36,           2,  40,   [6, 14, 26, 34]],\n    [16,           12, 48,   [2, 4,  8,  10, 14, 16, 20, 22, 26, 28, 32, 34, 38, 40, 44, 46]],\n    [13,           6,  112,  undef],\n    [52,           6,  117,  undef],\n    [48,           3,  128,  undef],\n    [382,          3,  1000, undef],\n    [10,           3,  81,   [13, 40,  67]],\n    [26,           5,  625,  [81, 206, 331, 456, 581]],\n    [51,           5,  625,  [61, 186, 311, 436, 561]],\n    [\"9833625071\", 3,  \"10000000071\", [qw/3333332807 6666666164 9999999521/]],\n\n    #[2131968,5,10000000000, [...]],   # Far too many\n    [198, -1, 519, undef],\n);\n\nforeach my $t (@rootmods) {\n    say \"Testing: kth_root_mod($t->[1], $t->[0], $t->[2])\";\n    is_deeply([kth_root_mod($t->[1], $t->[0], $t->[2])], (defined($t->[3]) ? $t->[3] : []));\n}\n\n# ----- CLI usage -----\nif (@ARGV == 3) {\n    my ($k, $v, $m) = @ARGV;\n    my @sol = kth_root_mod($k, $v, $m);\n    if (!@sol) {\n        print \"No solution: x^$k ≡ $v (mod $m) has no solution.\\n\";\n    }\n    else {\n        print scalar(@sol),                        \" solution(s) mod $m:\\n\";\n        print join(\", \", sort { $a <=> $b } @sol), \"\\n\";\n    }\n    exit 0;\n}\n"
  },
  {
    "path": "Math/modular_k-th_root_all_solutions_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 10 December 2025\n# https://github.com/trizen\n\n# kth_root_mod: find all x (0 <= x < m) with x^k ≡ a (mod m)\n\nuse 5.036;\nuse Test::More tests => 60;\nuse Math::GMPz qw(:mpz);\nuse ntheory    qw(:all);\n\n# Small helper: brute-force search for solutions mod p (p is small)\nsub _bruteforce_mod_p ($k, $r, $p) {\n    my $k_mpz = Math::GMPz->new($k);\n    my $r_mpz = Math::GMPz->new($r);\n    my $p_mpz = Math::GMPz->new($p);\n    my $pow   = Math::GMPz->new;\n    return map { Math::GMPz->new($_) } grep {\n        Rmpz_powm($pow, Math::GMPz->new($_), $k_mpz, $p_mpz);\n        $pow == $r_mpz;\n    } 0 .. ($p - 1);\n}\n\n# Solve x^k ≡ r (mod p) for prime p.\nsub solve_mod_p ($k_in, $r_in, $p_in) {\n    my $p    = Math::GMPz->new($p_in);\n    my $p_ui = $p + 0;\n    die \"p must be prime > 1\" unless $p_ui > 1 && is_prime($p_ui);\n\n    my $k_mpz = Math::GMPz->new($k_in);\n    my $r     = Math::GMPz->new($r_in);\n    Rmpz_mod($r, $r, $p);\n\n    return (Math::GMPz->new(0))                if $r == 0;       # trivial zero solution\n    return _bruteforce_mod_p($k_in, $r, $p_ui) if $p_ui <= 31;\n\n    my $phi = Math::GMPz->new($p);\n    Rmpz_sub_ui($phi, $phi, 1);\n\n    my $d = Math::GMPz->new;\n    Rmpz_gcd($d, $k_mpz, $phi);\n\n    my $phi_over_d = Math::GMPz->new;\n    Rmpz_fdiv_q($phi_over_d, $phi, $d);\n\n    my $r_check = Math::GMPz->new;\n    Rmpz_powm($r_check, $r, $phi_over_d, $p);\n    return () if $r_check != 1;    # necessary condition\n\n    return ($r) if $k_in == 1;\n\n    my $g = znprimroot($p_ui) // return _bruteforce_mod_p($k_in, $r, $p_ui);\n    my $a = znlog($r, $g, $p_ui);\n    return () unless defined $a;\n\n    my $k1   = Math::GMPz->new;\n    my $phi1 = Math::GMPz->new;\n    my $a1   = Math::GMPz->new;\n    Rmpz_fdiv_q($k1,   $k_mpz, $d);\n    Rmpz_fdiv_q($phi1, $phi,   $d);\n    Rmpz_fdiv_q_ui($a1, Math::GMPz->new($a), $d);\n\n    my $inv_k1 = Math::GMPz->new;\n    return () unless Rmpz_invert($inv_k1, $k1, $phi1);\n\n    my $t0 = Math::GMPz->new;\n    Rmpz_mul($t0, $a1, $inv_k1);\n    Rmpz_mod($t0, $t0, $phi1);\n\n    my $g_mpz   = Math::GMPz->new($g);\n    my $res     = Math::GMPz->new;\n    my $tmp_exp = Math::GMPz->new;\n    my $mul     = Math::GMPz->new;\n\n    my $d_ui = $d + 0;\n    return map {\n        Rmpz_set($tmp_exp, $t0);\n        Rmpz_mul_ui($mul, $phi1, $_);\n        Rmpz_add($tmp_exp, $tmp_exp, $mul);\n        Rmpz_powm($res, $g_mpz, $tmp_exp, $p);\n        Math::GMPz->new($res);\n    } 0 .. $d_ui - 1;\n}\n\n# Solve x^k ≡ r (mod p^e) for prime powers by lifting.\nsub solve_prime_power_lift ($k_in, $r_in, $p_in, $e) {\n    my $p     = Math::GMPz->new($p_in);\n    my $k_mpz = Math::GMPz->new($k_in);\n    my $r     = Math::GMPz->new($r_in);\n\n    my $mod = Math::GMPz->new;\n    Rmpz_pow_ui($mod, $p, $e);\n    Rmpz_mod($r, $r, $mod);\n    return () if $mod == 0;\n\n    if ($r % $mod == 0) {    # x^k ≡ 0\n        my $vx_min = Math::GMPz->new;\n        Rmpz_add_ui($vx_min, Math::GMPz->new($e), $k_in - 1);\n        Rmpz_fdiv_q_ui($vx_min, $vx_min, $k_in);    # ceil(e/k)\n\n        my $base  = Math::GMPz->new;\n        my $limit = Math::GMPz->new;\n        Rmpz_pow_ui($base,  $p, \"$vx_min\");\n        Rmpz_pow_ui($limit, $p, $e - \"$vx_min\");\n        my $lim_i = $limit + 0;\n\n        return map {\n            my $t = Math::GMPz->new($base);\n            Rmpz_mul_ui($t, $t, $_);\n            $t;\n        } 0 .. $lim_i - 1;\n    }\n\n    my @sol = solve_mod_p($k_in, $r, $p);\n    return () unless @sol;\n    return @sol if $e == 1;\n\n    my $p_ui     = $p + 0;\n    my $t        = 1;\n    my $next_mod = Math::GMPz->new;\n    my $base     = Math::GMPz->new;\n    my $cand     = Math::GMPz->new;\n    my $check    = Math::GMPz->new;\n    my $r_next   = Math::GMPz->new;\n\n    while ($t < $e) {    # lift to p^{t+1}\n        Rmpz_pow_ui($next_mod, $p, $t + 1);\n        my @next;\n\n        for my $a (@sol) {\n            Rmpz_pow_ui($base, $p, $t);\n            for my $s (0 .. $p_ui - 1) {\n                Rmpz_set($cand, $base);\n                Rmpz_mul_ui($cand, $cand, $s);\n                Rmpz_add($cand, $cand, $a);\n                Rmpz_mod($cand, $cand, $next_mod);\n\n                Rmpz_powm($check, $cand, $k_mpz, $next_mod);\n                Rmpz_set($r_next, $r);\n                Rmpz_mod($r_next, $r_next, $next_mod);\n\n                push @next, Math::GMPz->new($cand) if $check == $r_next;\n            }\n        }\n        @sol = @next;\n        return () unless @sol;\n        ++$t;\n    }\n    return @sol;\n}\n\n# All solutions to x^k ≡ r (mod m).\nsub kth_root_mod ($k_in, $r_in, $m_in) {\n    my $m     = Math::GMPz->new($m_in);\n    my $r     = Math::GMPz->new($r_in);\n    my $k_mpz = Math::GMPz->new($k_in);\n    return () if $m == 0;\n\n    if ($k_in == 0 && $r == 1) {    # any x satisfies x^0 = 1\n        my $m_i = $m + 0;\n        return map { Math::GMPz->new($_) } 0 .. $m_i - 1;\n    }\n\n    # Negative k: solve y^{|k|} ≡ r, then invert y -> x = y^{-1} mod m\n    if ($k_in < 0) {\n        my $g = Math::GMPz->new;\n        Rmpz_gcd($g, $r, $m);\n        return () if $g != 1;    # r must be a unit modulo m\n\n        my @y = kth_root_mod(-$k_in, $r, $m);\n        return () unless @y;\n\n        my $y_mod = Math::GMPz->new;\n        my $inv   = Math::GMPz->new;\n        my @xs;\n        for my $yy (@y) {\n            Rmpz_set($y_mod, $yy);\n            Rmpz_mod($y_mod, $y_mod, $m);\n            push @xs, Math::GMPz->new($inv) if Rmpz_invert($inv, $y_mod, $m);\n        }\n        return sort { $a <=> $b } @xs;\n    }\n\n    my @factors = factor_exp(\"$m\");                              # [p, e] pairs\n    my @current = ([Math::GMPz->new(0), Math::GMPz->new(1)]);    # [residue, modulus]\n\n    my $mod_pe = Math::GMPz->new;\n    my $r_pe   = Math::GMPz->new;\n\n    for my $fe (@factors) {\n        my ($p_scalar, $e) = @$fe;\n        my $p = Math::GMPz->new($p_scalar);\n\n        Rmpz_pow_ui($mod_pe, $p, $e);\n        Rmpz_set($r_pe, $r);\n        Rmpz_mod($r_pe, $r_pe, $mod_pe);\n\n        my @sol_pe = solve_prime_power_lift($k_in, $r_pe, $p, $e);\n        return () unless @sol_pe;\n\n        my @next;\n        for my $pe (@sol_pe) {\n            for my $cur (@current) {\n                my ($A, $mod_a) = @$cur;\n                my $combined = chinese([\"$A\", \"$mod_a\"], [\"$pe\", \"$mod_pe\"]);\n                push @next, [Math::GMPz->new($combined), Math::GMPz->new($mod_a) * $mod_pe];\n            }\n        }\n        @current = @next;\n    }\n\n    return sort { $a <=> $b } map {\n        my $tmp = Math::GMPz->new($_->[0]);\n        Rmpz_mod($tmp, $tmp, $m);\n        $tmp;\n    } @current;\n}\n\nis_deeply([kth_root_mod(3, 2, 101)], [26]);\nis_deeply([kth_root_mod(2, 0, 16)],  [0, 4, 8, 12]);\nis_deeply([kth_root_mod(2, 1, 101)], [1, 100]);\nis_deeply([kth_root_mod(5, 4320, 5040)],\n          [120, 330, 540, 750, 960, 1170, 1380, 1590, 1800, 2010, 2220, 2430, 2640, 2850, 3060, 3270, 3480, 3690, 3900, 4110, 4320, 4530, 4740, 4950]);\nis_deeply(\n          [kth_root_mod(6, 4320, 5040)],\n          [30,   60,   90,   120,  150,  180,  240,  270,  300,  330,  360,  390,  450,  480,  510,  540,  570,  600,  660,  690,  720,  750,  780,  810,\n           870,  900,  930,  960,  990,  1020, 1080, 1110, 1140, 1170, 1200, 1230, 1290, 1320, 1350, 1380, 1410, 1440, 1500, 1530, 1560, 1590, 1620, 1650,\n           1710, 1740, 1770, 1800, 1830, 1860, 1920, 1950, 1980, 2010, 2040, 2070, 2130, 2160, 2190, 2220, 2250, 2280, 2340, 2370, 2400, 2430, 2460, 2490,\n           2550, 2580, 2610, 2640, 2670, 2700, 2760, 2790, 2820, 2850, 2880, 2910, 2970, 3000, 3030, 3060, 3090, 3120, 3180, 3210, 3240, 3270, 3300, 3330,\n           3390, 3420, 3450, 3480, 3510, 3540, 3600, 3630, 3660, 3690, 3720, 3750, 3810, 3840, 3870, 3900, 3930, 3960, 4020, 4050, 4080, 4110, 4140, 4170,\n           4230, 4260, 4290, 4320, 4350, 4380, 4440, 4470, 4500, 4530, 4560, 4590, 4650, 4680, 4710, 4740, 4770, 4800, 4860, 4890, 4920, 4950, 4980, 5010\n          ]\n         );\nis_deeply(\n          [kth_root_mod(124, 2016, 5040)],\n          [42,   84,   126,  168,  252,  294,  336,  378,  462,  504,  546,  588,  672,  714,  756,  798,  882,  924,  966,  1008, 1092, 1134, 1176, 1218,\n           1302, 1344, 1386, 1428, 1512, 1554, 1596, 1638, 1722, 1764, 1806, 1848, 1932, 1974, 2016, 2058, 2142, 2184, 2226, 2268, 2352, 2394, 2436, 2478,\n           2562, 2604, 2646, 2688, 2772, 2814, 2856, 2898, 2982, 3024, 3066, 3108, 3192, 3234, 3276, 3318, 3402, 3444, 3486, 3528, 3612, 3654, 3696, 3738,\n           3822, 3864, 3906, 3948, 4032, 4074, 4116, 4158, 4242, 4284, 4326, 4368, 4452, 4494, 4536, 4578, 4662, 4704, 4746, 4788, 4872, 4914, 4956, 4998\n          ]\n         );\nis_deeply([kth_root_mod(5, 43,  5040)], [1723]);\nis_deeply([kth_root_mod(5, 243, 1000)], [3, 203, 403, 603, 803]);\nis_deeply(\n          [kth_root_mod(383, 32247425005, 64552988163)],\n          [49,          168545710,   337091371,   505637032,   674182693,   842728354,   1011274015,  1179819676,  1348365337,  1516910998,\n           1685456659,  1854002320,  2022547981,  2191093642,  2359639303,  2528184964,  2696730625,  2865276286,  3033821947,  3202367608,\n           3370913269,  3539458930,  3708004591,  3876550252,  4045095913,  4213641574,  4382187235,  4550732896,  4719278557,  4887824218,\n           5056369879,  5224915540,  5393461201,  5562006862,  5730552523,  5899098184,  6067643845,  6236189506,  6404735167,  6573280828,\n           6741826489,  6910372150,  7078917811,  7247463472,  7416009133,  7584554794,  7753100455,  7921646116,  8090191777,  8258737438,\n           8427283099,  8595828760,  8764374421,  8932920082,  9101465743,  9270011404,  9438557065,  9607102726,  9775648387,  9944194048,\n           10112739709, 10281285370, 10449831031, 10618376692, 10786922353, 10955468014, 11124013675, 11292559336, 11461104997, 11629650658,\n           11798196319, 11966741980, 12135287641, 12303833302, 12472378963, 12640924624, 12809470285, 12978015946, 13146561607, 13315107268,\n           13483652929, 13652198590, 13820744251, 13989289912, 14157835573, 14326381234, 14494926895, 14663472556, 14832018217, 15000563878,\n           15169109539, 15337655200, 15506200861, 15674746522, 15843292183, 16011837844, 16180383505, 16348929166, 16517474827, 16686020488,\n           16854566149, 17023111810, 17191657471, 17360203132, 17528748793, 17697294454, 17865840115, 18034385776, 18202931437, 18371477098,\n           18540022759, 18708568420, 18877114081, 19045659742, 19214205403, 19382751064, 19551296725, 19719842386, 19888388047, 20056933708,\n           20225479369, 20394025030, 20562570691, 20731116352, 20899662013, 21068207674, 21236753335, 21405298996, 21573844657, 21742390318,\n           21910935979, 22079481640, 22248027301, 22416572962, 22585118623, 22753664284, 22922209945, 23090755606, 23259301267, 23427846928,\n           23596392589, 23764938250, 23933483911, 24102029572, 24270575233, 24439120894, 24607666555, 24776212216, 24944757877, 25113303538,\n           25281849199, 25450394860, 25618940521, 25787486182, 25956031843, 26124577504, 26293123165, 26461668826, 26630214487, 26798760148,\n           26967305809, 27135851470, 27304397131, 27472942792, 27641488453, 27810034114, 27978579775, 28147125436, 28315671097, 28484216758,\n           28652762419, 28821308080, 28989853741, 29158399402, 29326945063, 29495490724, 29664036385, 29832582046, 30001127707, 30169673368,\n           30338219029, 30506764690, 30675310351, 30843856012, 31012401673, 31180947334, 31349492995, 31518038656, 31686584317, 31855129978,\n           32023675639, 32192221300, 32360766961, 32529312622, 32697858283, 32866403944, 33034949605, 33203495266, 33372040927, 33540586588,\n           33709132249, 33877677910, 34046223571, 34214769232, 34383314893, 34551860554, 34720406215, 34888951876, 35057497537, 35226043198,\n           35394588859, 35563134520, 35731680181, 35900225842, 36068771503, 36237317164, 36405862825, 36574408486, 36742954147, 36911499808,\n           37080045469, 37248591130, 37417136791, 37585682452, 37754228113, 37922773774, 38091319435, 38259865096, 38428410757, 38596956418,\n           38765502079, 38934047740, 39102593401, 39271139062, 39439684723, 39608230384, 39776776045, 39945321706, 40113867367, 40282413028,\n           40450958689, 40619504350, 40788050011, 40956595672, 41125141333, 41293686994, 41462232655, 41630778316, 41799323977, 41967869638,\n           42136415299, 42304960960, 42473506621, 42642052282, 42810597943, 42979143604, 43147689265, 43316234926, 43484780587, 43653326248,\n           43821871909, 43990417570, 44158963231, 44327508892, 44496054553, 44664600214, 44833145875, 45001691536, 45170237197, 45338782858,\n           45507328519, 45675874180, 45844419841, 46012965502, 46181511163, 46350056824, 46518602485, 46687148146, 46855693807, 47024239468,\n           47192785129, 47361330790, 47529876451, 47698422112, 47866967773, 48035513434, 48204059095, 48372604756, 48541150417, 48709696078,\n           48878241739, 49046787400, 49215333061, 49383878722, 49552424383, 49720970044, 49889515705, 50058061366, 50226607027, 50395152688,\n           50563698349, 50732244010, 50900789671, 51069335332, 51237880993, 51406426654, 51574972315, 51743517976, 51912063637, 52080609298,\n           52249154959, 52417700620, 52586246281, 52754791942, 52923337603, 53091883264, 53260428925, 53428974586, 53597520247, 53766065908,\n           53934611569, 54103157230, 54271702891, 54440248552, 54608794213, 54777339874, 54945885535, 55114431196, 55282976857, 55451522518,\n           55620068179, 55788613840, 55957159501, 56125705162, 56294250823, 56462796484, 56631342145, 56799887806, 56968433467, 57136979128,\n           57305524789, 57474070450, 57642616111, 57811161772, 57979707433, 58148253094, 58316798755, 58485344416, 58653890077, 58822435738,\n           58990981399, 59159527060, 59328072721, 59496618382, 59665164043, 59833709704, 60002255365, 60170801026, 60339346687, 60507892348,\n           60676438009, 60844983670, 61013529331, 61182074992, 61350620653, 61519166314, 61687711975, 61856257636, 62024803297, 62193348958,\n           62361894619, 62530440280, 62698985941, 62867531602, 63036077263, 63204622924, 63373168585, 63541714246, 63710259907, 63878805568,\n           64047351229, 64215896890, 64384442551\n          ]\n         );\n\nis_deeply(\n          [kth_root_mod(3432, 33, 10428581733134514527),],\n          [234538669356049904,  265172539733867379,  338494374696194946,  468144956219368759,   587920784072174975,   866212217277838851,\n           1191587698502237300, 1469879131707901176, 2012837926243083376, 2116793631583228418,  2246444213106402231,  2616504840673145701,\n           2819477257158647081, 2850111127536464556, 2969886955389270772, 3248178388594934648,  3672570580964689435,  3950862014170353311,\n           4095753547647065419, 4374044980852729295, 4597776514045680553, 4699420462077127744,  4977711895282791620,  5201443428475742878,\n           5227138304658771649, 5450869837851722907, 5729161271057386783, 5830805219088833974,  6054536752281785232,  6332828185487449108,\n           6477719718964161216, 6756011152169825092, 7180403344539579879, 7458694777745243755,  7578470605598049971,  7609104475975867446,\n           7812076892461368826, 8182137520028112296, 8311788101551286109, 8415743806891431151,  8958702601426613351,  9236994034632277227,\n           9562369515856675676, 9840660949062339552, 9960436776915145768, 10090087358438319581, 10163409193400647148, 10194043063778464623\n          ]\n         );\n\n# Check:\n#   p {prime, prime power, square-free composite, non-SF composite}\n#   k {prime, prime power, square-free composite, non-SF composite}\nmy @rootmods = (\n\n    # prime moduli\n    [14,    -3, 101,    [17]],\n    [13,     6, 107,    [24, 83]],\n    [13,    -6, 107,    [49, 58]],\n    [64,     6, 101,    [2,  99]],\n    [9,     -2, 101,    [34, 67]],\n    [2,      3, 3,      [2]],\n    [2,      3, 7,      undef],\n    [17,    29, 19,     [6]],\n    [5,      3, 13,     [7,     8,  11]],\n    [53,     3, 151,    [15,    27, 109]],\n    [3,      3, 73,     [25,    54, 67]],\n    [7,      3, 73,     [13,    29, 31]],\n    [49,     3, 73,     [12,    23, 38]],\n    [44082,  4, 100003, [2003,  98000]],\n    [90594,  6, 100019, [37071, 62948]],\n    [6,      5, 31,     [11,    13, 21, 22, 26]],\n    [0,      2, 2,      [0]],\n    [2,      4, 5,      undef],\n    [51,    12, 10009,  [64, 1203, 3183, 3247, 3999, 4807, 5202, 6010, 6762, 6826, 8806, 9945]],\n\n    #[15,3,\"1000000000000000000117\",[qw/72574612502199260377 361680004182786118804 565745383315014620936/]],\n    [1,  0, 13, [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12]],\n    [2,  0, 13, undef],\n    [0,  5, 0,  undef],\n    [0, -1, 3,  undef],\n\n    # composite moduli.\n    # Pari will usually give a *wrong* answer for these if using Mod(a,p).\n    # The right way with Pari is to use p-adic.\n    [4,  2, 10,   [2, 8]],\n    [4,  2, 18,   [2, 16]],\n    [2,  3, 21,   undef],                                                # Pari says 2\n    [8,  3, 27,   [2,   11,  20]],                                       # Pari says 26\n    [22, 3, 1505, [148, 578, 673, 793, 813, 1103, 1243, 1318, 1458]],    # Pari says 1408\n    [58787, 3, 100035,\n     [3773,  8633,  10793, 13763, 19163, 24293, 26183, 26588, 31313, 37118, 41978, 44138, 47108, 52508,\n      57638, 59528, 59933, 64658, 70463, 75323, 77483, 80453, 85853, 90983, 92873, 93278, 98003\n     ]\n    ],\n    [3748, 2, 4992,\n     [154,  262,  314,  518,  730,  934,  986,  1094, 1402, 1510, 1562, 1766, 1978, 2182, 2234, 2342,\n      2650, 2758, 2810, 3014, 3226, 3430, 3482, 3590, 3898, 4006, 4058, 4262, 4474, 4678, 4730, 4838\n     ]\n    ],\n    [68,           2,  2048, [46,  466, 558, 978,  1070, 1490, 1582, 2002]],\n    [96,           5,  128,  [6,   14,  22,  30,   38,   46,   54,   62,   70,   78,   86,   94,   102,  110,  118,  126]],\n    [2912,         5,  4992, [182, 494, 806, 1118, 1430, 1742, 2054, 2366, 2678, 2990, 3302, 3614, 3926, 4238, 4550, 4862]],\n    [2,            3,  4,    undef],\n    [3,            2,  4,    undef],\n    [3,            4,  19,   undef],\n    [1,            4,  20,   [1, 3, 7,  9, 11, 13, 17, 19]],\n    [9,            2,  24,   [3, 9, 15, 21]],\n    [6,            6,  35,   undef],\n    [36,           2,  40,   [6, 14, 26, 34]],\n    [16,           12, 48,   [2, 4,  8,  10, 14, 16, 20, 22, 26, 28, 32, 34, 38, 40, 44, 46]],\n    [13,           6,  112,  undef],\n    [52,           6,  117,  undef],\n    [48,           3,  128,  undef],\n    [382,          3,  1000, undef],\n    [10,           3,  81,   [13, 40,  67]],\n    [26,           5,  625,  [81, 206, 331, 456, 581]],\n    [51,           5,  625,  [61, 186, 311, 436, 561]],\n    [\"9833625071\", 3,  \"10000000071\", [qw/3333332807 6666666164 9999999521/]],\n\n    #[2131968,5,10000000000, [...]],   # Far too many\n    [198, -1, 519, undef],\n);\n\nforeach my $t (@rootmods) {\n    say \"Testing: kth_root_mod($t->[1], $t->[0], $t->[2])\";\n    is_deeply([kth_root_mod($t->[1], $t->[0], $t->[2])], (defined($t->[3]) ? $t->[3] : []));\n}\n\n# ----- CLI usage -----\nif (@ARGV == 3) {\n    my ($k, $v, $m) = @ARGV;\n    my @sol = kth_root_mod($k, $v, $m);\n    if (!@sol) {\n        print \"No solution: x^$k ≡ $v (mod $m) has no solution.\\n\";\n    }\n    else {\n        print scalar(@sol),                        \" solution(s) mod $m:\\n\";\n        print join(\", \", sort { $a <=> $b } @sol), \"\\n\";\n    }\n    exit 0;\n}\n"
  },
  {
    "path": "Math/modular_lucas_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Efficient algorithm for computing the nth-Lucas number (mod m).\n\n# Algorithm from:\n#   https://metacpan.org/source/KRYDE/Math-NumSeq-72/lib/Math/NumSeq/LucasNumbers.pm\n\n# See also:\n#   https://en.wikipedia.org/wiki/Lucas_number\n\nuse 5.020;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Math::GMPz;\nuse Math::Prime::Util::GMP qw(gcd consecutive_integer_lcm);\n\nsub lucasmod ($n, $m) {\n\n    $n = Math::GMPz->new(\"$n\");\n    $m = Math::GMPz->new(\"$m\");\n\n    my ($f, $g, $w) = (\n        Math::GMPz::Rmpz_init_set_ui(3),\n        Math::GMPz::Rmpz_init_set_ui(1),\n    );\n\n    foreach my $bit (split(//, substr(Math::GMPz::Rmpz_get_str($n, 2), 1))) {\n\n        Math::GMPz::Rmpz_powm_ui($g, $g, 2, $m);\n        Math::GMPz::Rmpz_powm_ui($f, $f, 2, $m);\n\n        $w\n          ? do {\n            Math::GMPz::Rmpz_sub_ui($g, $g, 2);\n            Math::GMPz::Rmpz_add_ui($f, $f, 2);\n          }\n          : do {\n            Math::GMPz::Rmpz_add_ui($g, $g, 2);\n            Math::GMPz::Rmpz_sub_ui($f, $f, 2);\n          };\n\n        if ($bit) {\n            Math::GMPz::Rmpz_sub($g, $f, $g);\n            $w = 0;\n        }\n        else {\n            Math::GMPz::Rmpz_sub($f, $f, $g);\n            $w = 1;\n        }\n    }\n\n    Math::GMPz::Rmpz_mod($g, $g, $m);\n\n    return $g;\n}\n\nsub lucas_factorization ($n, $B = 10000) {\n\n    my $k = consecutive_integer_lcm($B);    # lcm(1..B)\n    my $L = lucasmod($k, $n);               # Lucas(k) (mod n)\n\n    return gcd($L - 2, $n);\n}\n\nsay lucas_factorization(\"121095274043\",             700);     #=> 470783           (p+1 is  700-smooth)\nsay lucas_factorization(\"544812320889004864776853\", 3000);    #=> 333732865481     (p-1 is 3000-smooth)\n"
  },
  {
    "path": "Math/modular_lucas_sequence_V.pl",
    "content": "#!/usr/bin/perl\n\n# Efficient algorithm due to Aleksey Koval for computing the Lucas V sequence (mod m).\n\n# See also:\n#   https://en.wikipedia.org/wiki/Lucas_sequence\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse Math::GMPz;\n\nsub lucas_V_mod ($P, $Q, $n, $m) {\n\n    $n = Math::GMPz->new(\"$n\");\n    $P = Math::GMPz->new(\"$P\");\n    $Q = Math::GMPz->new(\"$Q\");\n    $m = Math::GMPz->new(\"$m\");\n\n    my ($V1, $V2) = (Math::GMPz::Rmpz_init_set_ui(2), Math::GMPz::Rmpz_init_set($P));\n    my ($Q1, $Q2) = (Math::GMPz::Rmpz_init_set_ui(1), Math::GMPz::Rmpz_init_set_ui(1));\n\n    foreach my $bit (split(//, Math::GMPz::Rmpz_get_str($n, 2))) {\n\n        Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);\n        Math::GMPz::Rmpz_mod($Q1, $Q1, $m);\n\n        if ($bit) {\n            Math::GMPz::Rmpz_mul($Q2, $Q1, $Q);\n            Math::GMPz::Rmpz_mul($V1, $V1, $V2);\n            Math::GMPz::Rmpz_powm_ui($V2, $V2, 2, $m);\n            Math::GMPz::Rmpz_submul($V1, $P, $Q1);\n            Math::GMPz::Rmpz_submul_ui($V2, $Q2, 2);\n            Math::GMPz::Rmpz_mod($V1, $V1, $m);\n        }\n        else {\n            Math::GMPz::Rmpz_set($Q2, $Q1);\n            Math::GMPz::Rmpz_mul($V2, $V2, $V1);\n            Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $m);\n            Math::GMPz::Rmpz_submul($V2, $P, $Q1);\n            Math::GMPz::Rmpz_submul_ui($V1, $Q2, 2);\n            Math::GMPz::Rmpz_mod($V2, $V2, $m);\n        }\n    }\n\n    Math::GMPz::Rmpz_mod($V1, $V1, $m);\n\n    return $V1;\n}\n\nsay lucas_V_mod( 1, -1, 123456, 12345);    #=> 4487\nsay lucas_V_mod(-3,  4, 987654, 12345);    #=> 3928\nsay lucas_V_mod(-5, -7, 314159, 12345);    #=> 4565\n"
  },
  {
    "path": "Math/modular_lucas_sequences_U_V.pl",
    "content": "#!/usr/bin/perl\n\n# Algorithm due to M. Joye and J.-J. Quisquater for efficiently computing the Lucas U and V sequences (mod m).\n\n# See also:\n#   https://en.wikipedia.org/wiki/Lucas_sequence\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse Math::GMPz;\n\nsub lucas_UV_mod ($P, $Q, $n, $m) {\n\n    $n = Math::GMPz->new(\"$n\");\n    $P = Math::GMPz->new(\"$P\");\n    $Q = Math::GMPz->new(\"$Q\");\n    $m = Math::GMPz->new(\"$m\");\n\n    my $U1 = Math::GMPz::Rmpz_init_set_ui(1);\n\n    my ($V1, $V2) = (Math::GMPz::Rmpz_init_set_ui(2), Math::GMPz::Rmpz_init_set($P));\n    my ($Q1, $Q2) = (Math::GMPz::Rmpz_init_set_ui(1), Math::GMPz::Rmpz_init_set_ui(1));\n\n    my $t = Math::GMPz::Rmpz_init_set_ui(2);\n    my $s = Math::GMPz::Rmpz_remove($t, $n, $t);\n\n    foreach my $bit (split(//, substr(Math::GMPz::Rmpz_get_str($t, 2), 0, -1))) {\n\n        Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);\n        Math::GMPz::Rmpz_mod($Q1, $Q1, $m);\n\n        if ($bit) {\n\n            #~ Q2 = (Q1 * Q)%m\n            #~ U1 = (U1 * V2)%m\n            #~ V1 = (V2*V1 - P*Q1)%m\n            #~ V2 = (V2*V2 - 2*Q2)%m\n\n            Math::GMPz::Rmpz_mul($Q2, $Q1, $Q);\n            Math::GMPz::Rmpz_mul($U1, $U1, $V2);\n            Math::GMPz::Rmpz_mul($V1, $V1, $V2);\n\n            Math::GMPz::Rmpz_powm_ui($V2, $V2, 2, $m);\n            Math::GMPz::Rmpz_submul($V1, $Q1, $P);\n            Math::GMPz::Rmpz_submul_ui($V2, $Q2, 2);\n\n            Math::GMPz::Rmpz_mod($V1, $V1, $m);\n            Math::GMPz::Rmpz_mod($U1, $U1, $m);\n        }\n        else {\n            #~ Q2 = Q1\n            #~ U1 = (U1*V1 - Q1)%m\n            #~ V2 = (V2*V1 - P*Q1)%m\n            #~ V1 = (V1*V1 - 2*Q2)%m\n\n            Math::GMPz::Rmpz_set($Q2, $Q1);\n            Math::GMPz::Rmpz_mul($U1, $U1, $V1);\n            Math::GMPz::Rmpz_mul($V2, $V2, $V1);\n            Math::GMPz::Rmpz_sub($U1, $U1, $Q1);\n\n            Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $m);\n            Math::GMPz::Rmpz_submul($V2, $Q1, $P);\n            Math::GMPz::Rmpz_submul_ui($V1, $Q2, 2);\n\n            Math::GMPz::Rmpz_mod($V2, $V2, $m);\n            Math::GMPz::Rmpz_mod($U1, $U1, $m);\n        }\n    }\n\n    #~ Q1 = (Q1 * Q2)%m\n    #~ Q2 = (Q1 * Q)%m\n    #~ U1 = (U1*V1 - Q1)%m\n    #~ V1 = (V2*V1 - P*Q1)%m\n    #~ Q1 = (Q1 * Q2)%m\n\n    Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);\n    Math::GMPz::Rmpz_mul($Q2, $Q1, $Q);\n    Math::GMPz::Rmpz_mul($U1, $U1, $V1);\n    Math::GMPz::Rmpz_mul($V1, $V1, $V2);\n    Math::GMPz::Rmpz_sub($U1, $U1, $Q1);\n    Math::GMPz::Rmpz_submul($V1, $Q1, $P);\n    Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);\n\n    for (1 .. $s) {\n\n        #~ U1 = (U1 * V1)%m\n        #~ V1 = (V1*V1 - 2*Q1)%m\n        #~ Q1 = (Q1 * Q1)%m\n\n        Math::GMPz::Rmpz_mul($U1, $U1, $V1);\n        Math::GMPz::Rmpz_mod($U1, $U1, $m);\n        Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $m);\n        Math::GMPz::Rmpz_submul_ui($V1, $Q1, 2);\n        Math::GMPz::Rmpz_powm_ui($Q1, $Q1, 2, $m);\n    }\n\n    Math::GMPz::Rmpz_mod($U1, $U1, $m);\n    Math::GMPz::Rmpz_mod($V1, $V1, $m);\n\n    return ($U1, $V1);\n}\n\nsay join(' ', lucas_UV_mod( 1, -1, 123456, 12345));    #=> 1122 4487\nsay join(' ', lucas_UV_mod(-3,  4, 987654, 12345));    #=> 3855 3928\nsay join(' ', lucas_UV_mod(-5, -7, 314159, 12345));    #=> 8038 4565\n"
  },
  {
    "path": "Math/modular_pseudo_square_root.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 13 October 2017\n# https://github.com/trizen\n\n# Find the greatest divisor (mod m) of `n` that does not exceed the square root of `n`.\n\n# See also:\n#   https://projecteuler.net/problem=266\n\nuse 5.020;\nuse warnings;\n\nuse ntheory qw(factor mulmod);\nuse experimental qw(signatures);\n\nsub pseudo_square_root_mod ($n, $mod) {\n\n    my $sqrt_log = log(\"$n\") / 2;\n    my @factors  = factor($n);\n    my $end      = $#factors;\n\n    my $maximum_log = 0;\n    my $maximum_num = 0;\n\n    sub ($i, $log, $prod) {\n\n        if ($log > $maximum_log) {\n            $maximum_log = $log;\n            $maximum_num = $prod;\n        }\n\n        if ($i > $end) {\n            return;\n        }\n\n        if ($log + log($factors[$i]) <= $sqrt_log) {\n            __SUB__->($i + 1, $log, $prod) if ($i < $end);\n            __SUB__->($i + 1, $log + log($factors[$i]), mulmod($prod, $factors[$i], $mod));\n        }\n\n    }->(0, 0, 1);\n\n    return $maximum_num;\n}\n\nsay pseudo_square_root_mod(479001600,   10**16);    #=> 21600\nsay pseudo_square_root_mod(6469693230,  10**16);    #=> 79534\nsay pseudo_square_root_mod(12398712476, 10**16);    #=> 68\n\nsay pseudo_square_root_mod('614889782588491410',              10**8);     #=> 83152070\nsay pseudo_square_root_mod('3217644767340672907899084554130', 10**16);    #=> 1793779293633437\n"
  },
  {
    "path": "Math/modular_pseudo_square_root_2.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 05 June 2019\n# https://github.com/trizen\n\n# Find the greatest divisor (mod m) of `n` that does not exceed the square root of `n`.\n\n# See also:\n#   https://projecteuler.net/problem=266\n\nuse 5.020;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub pseudo_square_root_mod ($n, $mod) {\n\n    my $lim     = sqrtint($n);\n    my @factors = map { [$_, log($_)] } grep { $_ <= $lim } factor($n);\n\n    my @d        = ([1, 0]);\n    my $sqrt_log = log(\"$n\") / 2;\n\n    my %seen;\n    while (my $p = shift(@factors)) {\n        my @t;\n        foreach my $d (@d) {\n            if ($p->[1] + $d->[1] <= $sqrt_log) {\n                push @t, [mulmod($p->[0], $d->[0], $mod), $p->[1] + $d->[1]];\n            }\n        }\n        push @d, @t;\n    }\n\n    my $max_log = 0;\n    my $max_div = 0;\n\n    foreach my $d (@d) {\n        if ($d->[1] > $max_log) {\n            $max_div = $d->[0];\n            $max_log = $d->[1];\n        }\n    }\n\n    return $max_div;\n}\n\nsay pseudo_square_root_mod(479001600,   10**16);    #=> 21600\nsay pseudo_square_root_mod(6469693230,  10**16);    #=> 79534\nsay pseudo_square_root_mod(12398712476, 10**16);    #=> 68\n\nsay pseudo_square_root_mod('614889782588491410',              10**8);     #=> 83152070\nsay pseudo_square_root_mod('3217644767340672907899084554130', 10**16);    #=> 1793779293633437\n"
  },
  {
    "path": "Math/modular_sigma_of_unitary_divisors_of_factorial.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 17 August 2017\n# https://github.com/trizen\n\n# An efficient algorithm for computing:\n#\n#      --                 --\n#      |       ---         |\n#      |       \\           |\n#      |       /    d^k    |  (mod m)\n#      |       ---         |\n#      |       d|n!        |\n#      |  gcd(d, n!/d) = 1 |\n#      --                 --\n#\n\n# See also:\n#   https://projecteuler.net/problem=429\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(forprimes mulmod powmod vecsum todigits);\n\nsub factorial_power ($n, $p) {\n    ($n - vecsum(todigits($n, $p))) / ($p - 1);\n}\n\nsub sigma_of_unitary_divisors_of_factorial ($n, $k, $m) {\n\n    my $sigma = 1;\n\n    forprimes {\n        $sigma = mulmod($sigma, 1 + powmod($_, $k * factorial_power($n, $_), $m), $m);\n    } $n;\n\n    return $sigma;\n}\n\nmy $k = 2;\nmy $n = 100;\nmy $m = 123456;\n\nsay sigma_of_unitary_divisors_of_factorial($n, $k, $m);   #=> 104128\n"
  },
  {
    "path": "Math/modular_square_root.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 09 July 2018\n# https://github.com/trizen\n\n# Find (almost) all solutions to the quadratic congruence:\n#   x^2 = a (mod n)\n\nuse 5.020;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse List::Util qw(uniq);\nuse ntheory qw(factor_exp is_prime chinese forsetproduct);\nuse Math::AnyNum qw(:overload kronecker powmod valuation ipow);\n\nsub tonelli_shanks ($n, $p) {\n\n    $n %= $p;\n\n    return $p if ($n == 0);\n\n    my $q = $p - 1;\n    my $s = valuation($q, 2);\n\n    powmod($n, $q >> 1, $p) == $p - 1 and return;\n\n    $s == 1\n      and return powmod($n, ($p + 1) >> 2, $p);\n\n    $q >>= $s;\n\n    my $z = 1;\n    for (my $i = 2 ; $i < $p ; ++$i) {\n        if (kronecker($i, $p) == -1) {\n            $z = $i;\n            last;\n        }\n    }\n\n    my $c = powmod($z, $q, $p);\n    my $r = powmod($n, ($q + 1) >> 1, $p);\n    my $t = powmod($n, $q, $p);\n\n    while (($t - 1) % $p != 0) {\n\n        my $k = 1;\n        my $v = $t * $t % $p;\n\n        for (my $i = 1 ; $i < $s ; ++$i) {\n            if (($v - 1) % $p == 0) {\n                $k = powmod($c, 1 << ($s - $i - 1), $p);\n                $s = $i;\n                last;\n            }\n            $v = $v * $v % $p;\n        }\n\n        $r = $r * $k % $p;\n        $c = $k * $k % $p;\n        $t = $t * $c % $p;\n    }\n\n    return $r;\n}\n\nsub sqrt_mod_n ($z, $n) {\n\n    if ($n <= 1) {    # no solutions for n<=1\n        return;\n    }\n\n    $z %= $n;\n\n    if ($z == 0) {\n        return 0;\n    }\n\n    if (!($n & 1)) {    # n is even\n\n        if (!($n & ($n - 1))) {    # n is a power of two\n\n            if ($n == 2) {\n                return (1) if ($z & 1);\n                return;\n            }\n\n            if ($n == 4) {\n                return (1, 3) if ($z % 4 == 1);\n                return;\n            }\n\n            if ($n == 8) {\n                return (1, 3, 5, 7) if ($z % 8 == 1);\n                return;\n            }\n\n            if ($z == 1) {\n                return (1, ($n >> 1) - 1, ($n >> 1) + 1, $n - 1);\n            }\n        }\n\n        my @roots;\n        my $k = valuation($n, 2);\n\n        foreach my $s (sqrt_mod_n($z, $n >> 1)) {\n\n            my $i = ((($s * $s - $z) >> ($k - 1)) % 2);\n            my $r = ($s + ($i << ($k - 2)));\n\n            if (($r * $r) % $n == $z) {\n                push(@roots, $r, $n - $r);\n            }\n        }\n\n        return sort { $a <=> $b } uniq(@roots);\n    }\n\n    if (is_prime($n)) {\n        my $r = tonelli_shanks($z, $n) // return;\n        return sort { $a <=> $b } ($r, $n - $r);\n    }\n\n    my @pe = factor_exp($n);    # factorize `n` into prime powers\n\n    if (@pe == 1) {\n        my $p = Math::AnyNum->new($pe[0][0]);\n        my $x = tonelli_shanks($z, $p) // return;\n        my $r = $n / $p;\n        my $e = ($n - 2 * $r + 1) >> 1;\n        my $t = (powmod($x, $r, $n) * powmod($z, $e, $n)) % $n;\n        return if ($t == 0);\n        return sort { $a <=> $b } ($t, $n - $t);\n    }\n\n    my @chinese;\n\n    foreach my $p (@pe) {\n        my $m = ipow($p->[0], $p->[1]);\n        my @r = sqrt_mod_n($z, $m);\n        push @chinese, [map { [$_, $m] } @r];\n    }\n\n    my @roots;\n\n    forsetproduct {\n        push @roots, chinese(@_);\n    } @chinese;\n\n    return sort { $a <=> $b } uniq(grep { ($_ * $_) % $n == $z } @roots);\n}\n\nmy @tests = (\n    [1104, 6630],\n    [2641, 4465],\n    [993,  2048],\n    [472,   972],\n    [441,   920],\n    [841,   905],\n    [289,   992],\n);\n\nsub bf_sqrtmod ($z, $n) {\n    grep { ($_ * $_) % $n == $z } 1 .. $n;\n}\n\nforeach my $t (@tests) {\n    my @r = sqrt_mod_n($t->[0], $t->[1]);\n    say \"x^2 = $t->[0] (mod $t->[1]) = {\", join(', ', @r), \"}\";\n    die \"error1 for (@$t) -- @r\" if (@r != grep { ($_ * $_) % $t->[1] == $t->[0] } @r);\n    die \"error2 for (@$t) -- @r\" if (join(' ', @r) ne join(' ', bf_sqrtmod($t->[0], $t->[1])));\n}\n\nsay '';\n\n# The algorithm also works for arbitrary large integers\nsay join(' ', sqrt_mod_n(-1, 13**18 * 5**7));    #=> 633398078861605286438568 2308322911594648160422943 6477255756527023177780182 8152180589260066051764557\n\nforeach my $n (1 .. 100) {\n    my $m = int(rand(10000));\n    my $z = int(rand($m));\n\n    my @a1 = sqrt_mod_n($z, $m);\n    my @a2 = bf_sqrtmod($z, $m);\n\n    if (\"@a1\" ne \"@a2\") {\n        warn \"\\nerror for ($z, $m):\\n\\t(@a1) != (@a2)\\n\";\n    }\n}\n\nsay '';\n\n# Too few solutions for some inputs\nsay 'x^2 = 1701 (mod 6300) = {' . join(' ', sqrt_mod_n(1701, 6300)) . '}';\nsay 'x^2 = 1701 (mod 6300) = {' . join(', ', bf_sqrtmod(1701, 6300)) . '}';\n\n# No solutions for some inputs (although solutions do exist)\nsay join(' ', sqrt_mod_n(306, 810));\nsay join(' ', sqrt_mod_n(2754, 6561));\nsay join(' ', sqrt_mod_n(17640, 48465));\n\n__END__\nx^2 = 1104 (mod 6630) = {642, 1152, 1968, 2478, 4152, 4662, 5478, 5988}\nx^2 = 2641 (mod 4465) = {1501, 2071, 2394, 2964}\nx^2 = 993 (mod 2048) = {369, 655, 1393, 1679}\nx^2 = 472 (mod 972) = {38, 448, 524, 934}\nx^2 = 441 (mod 920) = {21, 71, 159, 209, 251, 301, 389, 439, 481, 531, 619, 669, 711, 761, 849, 899}\nx^2 = 841 (mod 905) = {29, 391, 514, 876}\nx^2 = 289 (mod 992) = {17, 79, 417, 479, 513, 575, 913, 975}\n"
  },
  {
    "path": "Math/modular_square_root_2.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 21 July 2018\n# https://github.com/trizen\n\n# Find (almost) all solutions to the quadratic congruence:\n#   x^2 = a (mod n)\n\nuse 5.020;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse List::Util qw(uniq);\nuse ntheory qw(factor_exp chinese forsetproduct);\nuse Math::Prime::Util::GMP qw(sqrtmod);\nuse Math::AnyNum qw(:overload powmod ipow);\n\nsub sqrt_mod_n ($z, $n) {\n\n    my @roots = sub ($z, $n) {\n\n        return 0  if ($n == 1);\n        return () if ($n < 1);\n\n        $z %= $n;\n\n        return $n if ($z == 0);\n\n        my %congruences;\n\n        foreach my $factor (factor_exp($n)) {\n\n            my ($p, $e) = @$factor;\n            my $pp = ipow($p, $e);\n\n            if ($p eq '2') {\n\n                if ($e == 1) {\n                    if ($z & 1) {\n                        push @{$congruences{$pp}}, [1, $pp];\n                    }\n                    else {\n                        push @{$congruences{$pp}}, [0, $pp];\n                    }\n                }\n                elsif ($e == 2) {\n                    if ($z % 4 == 1) {\n                        push @{$congruences{$pp}}, [1, $pp], [3, $pp];\n                    }\n                    else {\n                        push @{$congruences{$pp}}, [0, $pp], [2, $pp];\n                    }\n                }\n                elsif ($e == 3) {\n                    if ($z % 8 == 1) {\n                        push @{$congruences{$pp}}, [1, $pp], [3, $pp], [5, $pp], [7, $pp];\n                    }\n                    else {\n                        push @{$congruences{$pp}}, [0, $pp], [2, $pp], [4, $pp], [6, $pp];\n                    }\n                }\n                elsif ($z == 1) {\n                    push @{$congruences{$pp}}, [1, $pp], [($pp >> 1) - 1, $pp], [($pp >> 1) + 1, $pp], [$pp - 1, $pp];\n                }\n\n                foreach my $s (__SUB__->($z, $pp >> 1)) {\n\n                    my $i = ((($s * $s - $z) >> ($e - 1)) % 2);\n                    my $r = ($s + ($i << ($e - 2)));\n\n                    push @{$congruences{$pp}}, [$r, $pp], [$pp - $r, $pp];\n                }\n\n                next;\n            }\n\n            $p = Math::AnyNum->new($p);\n            my $x = sqrtmod($z, $p) // next;   # Tonelli-Shanks algorithm\n            my $r = $pp / $p;\n            my $u = ($pp - 2 * $r + 1) >> 1;\n            my $t = (powmod($x, $r, $pp) * powmod($z, $u, $pp)) % $pp;\n            push @{$congruences{$pp}}, [$t, $pp], [$pp - $t, $pp];\n        }\n\n        my @roots;\n\n        forsetproduct {\n            push @roots, chinese(@_);\n        } values %congruences;\n\n        return grep { powmod($_, 2, $n) == $z } uniq(@roots);\n    }->($z, $n);\n\n    sort { $a <=> $b } @roots;\n}\n\nmy @tests = ([1104, 6630], [2641, 4465], [993, 2048], [472, 972], [441, 920], [841, 905], [289, 992],);\n\nsub bf_sqrtmod ($z, $n) {\n    grep { ($_ * $_) % $n == $z } 1 .. $n;\n}\n\nforeach my $t (@tests) {\n    my @r = sqrt_mod_n($t->[0], $t->[1]);\n    say \"x^2 = $t->[0] (mod $t->[1]) = {\", join(', ', @r), \"}\";\n    die \"error1 for (@$t) -- @r\" if (@r != grep { ($_ * $_) % $t->[1] == $t->[0] } @r);\n    die \"error2 for (@$t) -- @r\" if (join(' ', @r) ne join(' ', bf_sqrtmod($t->[0], $t->[1])));\n}\n\nsay '';\n\n# The algorithm also works for arbitrary large integers\nsay join(' ', sqrt_mod_n(13**18 * 5**7 - 1, 13**18 * 5**7));    #=> 633398078861605286438568 2308322911594648160422943 6477255756527023177780182 8152180589260066051764557\n\nforeach my $n (1 .. 100) {\n    my $m = int(rand(10000));\n    my $z = int(rand($m));\n\n    my @a1 = sqrt_mod_n($z, $m);\n    my @a2 = bf_sqrtmod($z, $m);\n\n    if (\"@a1\" ne \"@a2\") {\n        warn \"\\nerror for ($z, $m):\\n\\t(@a1) != (@a2)\\n\";\n    }\n}\n\nsay '';\n\n# Too few solutions for some inputs\nsay 'x^2 = 1701 (mod 6300) = {' . join(' ', sqrt_mod_n(1701, 6300)) . '}';\nsay 'x^2 = 1701 (mod 6300) = {' . join(', ', bf_sqrtmod(1701, 6300)) . '}';\n\n# No solutions for some inputs (although solutions do exist)\nsay join(' ', sqrt_mod_n(306,   810));\nsay join(' ', sqrt_mod_n(2754,  6561));\nsay join(' ', sqrt_mod_n(17640, 48465));\n\n__END__\nx^2 = 1104 (mod 6630) = {642, 1152, 1968, 2478, 4152, 4662, 5478, 5988}\nx^2 = 2641 (mod 4465) = {1501, 2071, 2394, 2964}\nx^2 = 993 (mod 2048) = {369, 655, 1393, 1679}\nx^2 = 472 (mod 972) = {38, 448, 524, 934}\nx^2 = 441 (mod 920) = {21, 71, 159, 209, 251, 301, 389, 439, 481, 531, 619, 669, 711, 761, 849, 899}\nx^2 = 841 (mod 905) = {29, 391, 514, 876}\nx^2 = 289 (mod 992) = {17, 79, 417, 479, 513, 575, 913, 975}\n"
  },
  {
    "path": "Math/modular_square_root_3.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 26 February 2019\n# https://github.com/trizen\n\n# Find several integer solutions for x to the congruence:\n#   x^2 = a (mod n)\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\nuse experimental qw(signatures);\nuse ntheory qw();\nuse Math::Prime::Util::GMP qw();\n\nsub modular_square_root ($x, $y) {\n\n    $x = Math::GMPz->new(\"$x\");\n    $y = Math::GMPz->new(\"$y\");\n\n    Math::GMPz::Rmpz_sgn($y) <= 0 and return;\n\n    if (Math::Prime::Util::GMP::is_prob_prime($y)) {\n        my $r = Math::GMPz->new(Math::Prime::Util::GMP::sqrtmod($x, $y) // return);\n        return ($r, $y - $r);\n    }\n\n    my %factors;\n    ++$factors{$_} for Math::Prime::Util::GMP::factor($y);\n\n    my %congruences;\n\n    my $t = Math::GMPz::Rmpz_init();\n    my $u = Math::GMPz::Rmpz_init();\n    my $v = Math::GMPz::Rmpz_init();\n    my $w = Math::GMPz::Rmpz_init();\n    my $m = Math::GMPz::Rmpz_init();\n\n    Math::GMPz::Rmpz_mod($m, $x, $y);\n\n    foreach my $p (keys %factors) {\n\n        if ($p eq '2') {\n            my $e = $factors{$p};\n\n            if ($e == 1) {\n                push @{$congruences{$p}}, [(Math::GMPz::Rmpz_odd_p($m) ? 1 : 0), 2];\n                next;\n            }\n\n            if ($e == 2) {\n                push @{$congruences{$p}}, [(Math::GMPz::Rmpz_congruent_ui_p($m, 1, 4) ? 1 : 0), 4];\n                next;\n            }\n\n            Math::GMPz::Rmpz_congruent_ui_p($m, 1, 8) or return;\n            Math::GMPz::Rmpz_ui_pow_ui($v, 2, $e - 1);\n\n            foreach my $r (__SUB__->($m, $v)) {\n\n                Math::GMPz::Rmpz_mul($t, $r, $r);\n                Math::GMPz::Rmpz_sub($t, $t, $m);\n                Math::GMPz::Rmpz_div_2exp($t, $t, $e - 1);\n                Math::GMPz::Rmpz_mod_ui($t, $t, 2);\n\n                Math::GMPz::Rmpz_mul_2exp($t, $t, $e - 2);\n                Math::GMPz::Rmpz_add($t, $t, $r);\n\n                push @{$congruences{$p}}, [\"$t\", \"$v\"];\n            }\n            next;\n        }\n\n        my $r = Math::GMPz->new(Math::Prime::Util::GMP::sqrtmod($x, $p) // return);\n\n        foreach my $w (Math::GMPz->new(\"$r\"), $p - $r) {\n\n            Math::GMPz::Rmpz_set_str($t, \"$p\", 10);\n\n            # v = p^k\n            Math::GMPz::Rmpz_pow_ui($v, $t, $factors{\"$p\"});\n\n            # t = p^(k-1)\n            Math::GMPz::Rmpz_divexact($t, $v, $t);\n\n            # u = (p^k - 2*(p^(k-1)) + 1) / 2\n            Math::GMPz::Rmpz_mul_2exp($u, $t, 1);\n            Math::GMPz::Rmpz_sub($u, $v, $u);\n            Math::GMPz::Rmpz_add_ui($u, $u, 1);\n            Math::GMPz::Rmpz_div_2exp($u, $u, 1);\n\n            # sqrtmod(a, p^k) = (powmod(sqrtmod(a, p), p^(k-1), p^k) * powmod(a, u, p^k)) % p^k\n            Math::GMPz::Rmpz_powm($w, $w, $t, $v);\n            Math::GMPz::Rmpz_powm($u, $m, $u, $v);\n            Math::GMPz::Rmpz_mul($w, $w, $u);\n            Math::GMPz::Rmpz_mod($w, $w, $v);\n\n            push @{$congruences{$p}}, [\"$w\", \"$v\"];\n        }\n    }\n\n    my @roots;\n\n#<<<\n    ntheory::forsetproduct {\n        push @roots, Math::Prime::Util::GMP::chinese(@_);\n    } values %congruences;\n#>>>\n\n    @roots = map { Math::GMPz->new($_) } @roots;\n\n    @roots = grep {\n        Math::GMPz::Rmpz_powm_ui($u, $_, 2, $y);\n        Math::GMPz::Rmpz_cmp($u, $m) == 0;\n    } @roots;\n\n    @roots = sort { $a <=> $b } @roots;\n\n    return @roots;\n}\n\nsay join ' ', modular_square_root(43,  97);         #=> 25 72\nsay join ' ', modular_square_root(472, 972);        #=> 448 524\nsay join ' ', modular_square_root(43,  41 * 97);    #=> 557 1042 2935 3420\nsay join ' ', modular_square_root(1104, 6630);      #=> 642 642 1152 1152 1968 1968 2478 2478 4152 4152 4662 4662 5478 5478 5988 5988\n\nsay '';\n\nsay join(' ', modular_square_root(993, 2048));    #=> 369 1679 655 1393\nsay join(' ', modular_square_root(441, 920));     #=> 761 481 209 849 531 251 899 619 301 21 669 389 71 711 439 159\nsay join(' ', modular_square_root(841, 905));     #=> 391 876 29 514\nsay join(' ', modular_square_root(289, 992));     #=> 417 513 975 79 913 17 479 575\n\n# No solutions for some inputs (although solutions do exist)\nsay join(' ', modular_square_root(306,   810));\nsay join(' ', modular_square_root(2754,  6561));\nsay join(' ', modular_square_root(17640, 48465));\n"
  },
  {
    "path": "Math/modular_square_root_all_solutions.pl",
    "content": "#!/usr/bin/perl\n\n# Find all solutions to the quadratic congruence:\n#   x^2 = a (mod n)\n\n# Based on algorithm by Hugo van der Sanden:\n#   https://github.com/danaj/Math-Prime-Util/pull/55\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Test::More tests => 11;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload ipow);\nuse ntheory qw(factor_exp sqrtmod forsetproduct chinese);\n\nsub sqrtmod_all ($A, $N) {\n\n    $A = Math::AnyNum->new(\"$A\");\n    $N = Math::AnyNum->new(\"$N\");\n\n    $N = -$N if ($N < 0);\n    $N == 0 and return ();\n    $N == 1 and return (0);\n    $A = ($A % $N);\n\n    my $sqrtmod_pk = sub ($A, $p, $k) {\n        my $pk = ipow($p, $k);\n\n        if ($A % $p == 0) {\n\n            if ($A % $pk == 0) {\n                my $low  = ipow($p, $k >> 1);\n                my $high = ($k & 1) ? ($low * $p) : $low;\n                return map { $high * $_ } 0 .. $low - 1;\n            }\n\n            my $A2 = $A / $p;\n            return () if ($A2 % $p != 0);\n            my $pj = $pk / $p;\n\n            return map {\n                my $q = $_;\n                map { $q * $p + $_ * $pj } 0 .. $p - 1\n            } __SUB__->($A2 / $p, $p, $k - 2);\n        }\n\n        my $q = sqrtmod($A, $pk) // eval {\n            require Math::Sidef;\n            Math::Sidef::sqrtmod($A, $pk);\n        } || return;\n\n        return ($q, $pk - $q) if ($p != 2);\n        return ($q)           if ($k == 1);\n        return ($q, $pk - $q) if ($k == 2);\n\n        my $pj = ipow($p, $k - 1);\n        my $q2 = ($q * ($pj - 1)) % $pk;\n\n        return ($q, $pk - $q, $q2, $pk - $q2);\n    };\n\n    my @congruences;\n\n    foreach my $pe (factor_exp($N)) {\n        my ($p, $k) = @$pe;\n        my $pk = ipow($p, $k);\n        push @congruences, [map { [$_, $pk] } $sqrtmod_pk->($A, $p, $k)];\n    }\n\n    my @roots;\n\n    forsetproduct {\n        push @roots, chinese(@_);\n    } @congruences;\n\n    @roots = map  { Math::AnyNum->new($_) } @roots;\n    @roots = grep { ($_ * $_) % $N == $A } @roots;\n    @roots = sort { $a <=> $b } @roots;\n\n    return @roots;\n}\n\n#<<<\nis_deeply([sqrtmod_all(43, 97)],       [25, 72]);\nis_deeply([sqrtmod_all(472, 972)],     [38, 448, 524, 934]);\nis_deeply([sqrtmod_all(43, 41 * 97)],  [557, 1042, 2935, 3420]);\nis_deeply([sqrtmod_all(1104, 6630)],   [642, 1152, 1968, 2478, 4152, 4662, 5478, 5988]);\nis_deeply([sqrtmod_all(993, 2048)],    [369, 655, 1393, 1679]);\nis_deeply([sqrtmod_all(441, 920)],     [21, 71, 159, 209, 251, 301, 389, 439, 481, 531, 619, 669, 711, 761, 849, 899]);\nis_deeply([sqrtmod_all(841, 905)],     [29, 391, 514, 876]);\nis_deeply([sqrtmod_all(289, 992)],     [17, 79, 417, 479, 513, 575, 913, 975]);\nis_deeply([sqrtmod_all(306, 810)],     [66, 96, 174, 204, 336, 366, 444, 474, 606, 636, 714, 744]);\nis_deeply([sqrtmod_all(2754, 6561)],   [126, 603, 855, 1332, 1584, 2061, 2313, 2790, 3042, 3519, 3771, 4248, 4500, 4977, 5229, 5706, 5958, 6435]);\nis_deeply([sqrtmod_all(17640, 48465)], [2865, 7905, 8250, 13290, 19020, 24060, 24405, 29445, 35175, 40215, 40560, 45600]);\n#>>>\n\nsay join', ', sqrtmod_all(-1, 13**18 * 5**7);    # 633398078861605286438568, 2308322911594648160422943, 6477255756527023177780182, 8152180589260066051764557\n"
  },
  {
    "path": "Math/modular_square_root_all_solutions_cipolla.pl",
    "content": "#!/usr/bin/perl\n\n# Find all the solutions to the quadratic congruence:\n#   x^2 = a (mod n)\n\n# Based on algorithm by Hugo van der Sanden:\n#   https://github.com/danaj/Math-Prime-Util/pull/55\n\n# See also:\n#   https://rosettacode.org/wiki/Cipolla's_algorithm\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Test::More tests => 12;\n\nuse experimental qw(signatures);\nuse ntheory qw(factor_exp chinese forsetproduct kronecker);\nuse Math::AnyNum qw(:overload powmod ipow);\n\nsub cipolla ($n, $p) {\n\n    $n %= $p;\n\n    return undef if kronecker($n, $p) != 1;\n\n    if ($p == 2) {\n        return ($n & 1);\n    }\n\n    my $w2;\n    my $a = 0;\n\n    $a++ until kronecker(($w2 = ($a * $a - $n) % $p), $p) < 0;\n\n    my %r = (x => 1, y => 0);\n    my %s = (x => $a, y => 1);\n    my $i = $p + 1;\n\n    while (1 <= ($i >>= 1)) {\n        %r = (\n              x => (($r{x} * $s{x} + $r{y} * $s{y} * $w2) % $p),\n              y => (($r{x} * $s{y} + $s{x} * $r{y}) % $p)\n             )\n          if ($i & 1);\n        %s = (\n              x => (($s{x} * $s{x} + $s{y} * $s{y} * $w2) % $p),\n              y => (($s{x} * $s{y} + $s{x} * $s{y}) % $p)\n             );\n    }\n\n    $r{y} ? undef : $r{x};\n}\n\nsub sqrtmod_prime_power ($n, $p, $e) {    # sqrt(n) modulo a prime power p^e\n\n    if ($e == 1) {\n        return cipolla($n, $p);\n    }\n\n    # t = p^(k-1)\n    my $t = ipow($p, $e - 1);\n\n    # pp = p^k\n    my $pp = $t * $p;\n\n    # n %= p^k\n    $n %= $pp;\n\n    if ($n == 0) {\n        return 0;\n    }\n\n    if ($p == 2) {\n\n        if ($e == 1) {\n            return (($n & 1) ? 1 : 0);\n        }\n\n        if ($e == 2) {\n            return (($n % 4 == 1) ? 1 : 0);\n        }\n\n        ($n % 8 == 1) || return;\n\n        my $r = __SUB__->($n, $p, $e - 1) // return;\n\n        # (((r^2 - n) / 2^(e-1))%2) * 2^(e-2) + r\n        return ((((($r * $r - $n) >> ($e - 1)) % 2) << ($e - 2)) + $r);\n    }\n\n    my $s = cipolla($n, $p) // return;\n\n    # u = (p^k - 2*(p^(k-1)) + 1) / 2\n    my $u = ($pp - 2 * $t + 1) >> 1;\n\n    # sqrtmod(a, p^k) = (powmod(sqrtmod(a, p), p^(k-1), p^k) * powmod(a, u, p^k)) % p^k\n    (powmod($s, $t, $pp) * powmod($n, $u, $pp)) % $pp;\n}\n\nsub sqrtmod_all ($A, $N) {\n\n    $A = Math::AnyNum->new(\"$A\");\n    $N = Math::AnyNum->new(\"$N\");\n\n    $N = -$N if ($N < 0);\n    $N == 0 and return ();\n    $N == 1 and return (0);\n    $A = ($A % $N);\n\n    my $sqrtmod_pk = sub ($A, $p, $k) {\n        my $pk = ipow($p, $k);\n\n        if ($A % $p == 0) {\n\n            if ($A % $pk == 0) {\n                my $low  = ipow($p, $k >> 1);\n                my $high = ($k & 1) ? ($low * $p) : $low;\n                return map { $high * $_ } 0 .. $low - 1;\n            }\n\n            my $A2 = $A / $p;\n            return () if ($A2 % $p != 0);\n            my $pj = $pk / $p;\n\n            return map {\n                my $q = $_;\n                map { $q * $p + $_ * $pj } 0 .. $p - 1\n            } __SUB__->($A2 / $p, $p, $k - 2);\n        }\n\n        my $q = sqrtmod_prime_power($A, $p, $k) // return;\n\n        return ($q, $pk - $q) if ($p != 2);\n        return ($q)           if ($k == 1);\n        return ($q, $pk - $q) if ($k == 2);\n\n        my $pj = ipow($p, $k - 1);\n        my $q2 = ($q * ($pj - 1)) % $pk;\n\n        return ($q, $pk - $q, $q2, $pk - $q2);\n    };\n\n    my @congruences;\n\n    foreach my $pe (factor_exp($N)) {\n        my ($p, $k) = @$pe;\n        my $pk = ipow($p, $k);\n        push @congruences, [map { [$_, $pk] } $sqrtmod_pk->($A, $p, $k)];\n    }\n\n    my @roots;\n\n    forsetproduct {\n        push @roots, chinese(@_);\n    } @congruences;\n\n    @roots = map  { Math::AnyNum->new($_) } @roots;\n    @roots = grep { ($_ * $_) % $N == $A } @roots;\n    @roots = sort { $a <=> $b } @roots;\n\n    return @roots;\n}\n\nmy @tests = ([1104, 6630], [2641, 4465], [993, 2048], [472, 972], [441, 920], [841, 905], [289, 992]);\n\nsub bf_sqrtmod ($z, $n) {\n    grep { ($_ * $_) % $n == $z } 0 .. $n - 1;\n    #ntheory::allsqrtmod($z, $n);\n}\n\nforeach my $t (@tests) {\n    my @r = sqrtmod_all($t->[0], $t->[1]);\n    say \"x^2 = $t->[0] (mod $t->[1]) = {\", join(', ', @r), \"}\";\n    die \"error1 for (@$t) -- @r\" if (@r != grep { ($_ * $_) % $t->[1] == $t->[0] } @r);\n    die \"error2 for (@$t) -- @r\" if (join(' ', @r) ne join(' ', bf_sqrtmod($t->[0], $t->[1])));\n}\n\nsay '';\n\n# The algorithm also works for arbitrary large integers\nsay join(' ', sqrtmod_all(13**18 * 5**7 - 1, 13**18 * 5**7));\n\nforeach my $n (1 .. 100) {\n    my $m = int(rand(10000));\n    my $z = int(rand($m));\n\n    my @a1 = sqrtmod_all($z, $m);\n    my @a2 = bf_sqrtmod($z, $m);\n\n    if (\"@a1\" ne \"@a2\") {\n        warn \"\\nerror for ($z, $m):\\n\\t(@a1) != (@a2)\\n\";\n    }\n}\n\nsay '';\n\n# Too few solutions for some inputs\nsay 'x^2 = 1701 (mod 6300) = {' . join(' ',  sqrtmod_all(1701, 6300)) . '}';\nsay 'x^2 = 1701 (mod 6300) = {' . join(', ', bf_sqrtmod(1701, 6300)) . '}';\n\n# No solutions for some inputs (although solutions do exist)\nsay join(' ', sqrtmod_all(306,   810));\nsay join(' ', sqrtmod_all(2754,  6561));\nsay join(' ', sqrtmod_all(17640, 48465));\n\n#<<<\nis_deeply([sqrtmod_all(43, 97)],       [25, 72]);\nis_deeply([sqrtmod_all(472, 972)],     [38, 448, 524, 934]);\nis_deeply([sqrtmod_all(43, 41 * 97)],  [557, 1042, 2935, 3420]);\nis_deeply([sqrtmod_all(1104, 6630)],   [642, 1152, 1968, 2478, 4152, 4662, 5478, 5988]);\nis_deeply([sqrtmod_all(993, 2048)],    [369, 655, 1393, 1679]);\nis_deeply([sqrtmod_all(441, 920)],     [21, 71, 159, 209, 251, 301, 389, 439, 481, 531, 619, 669, 711, 761, 849, 899]);\nis_deeply([sqrtmod_all(841, 905)],     [29, 391, 514, 876]);\nis_deeply([sqrtmod_all(289, 992)],     [17, 79, 417, 479, 513, 575, 913, 975]);\nis_deeply([sqrtmod_all(306, 810)],     [66, 96, 174, 204, 336, 366, 444, 474, 606, 636, 714, 744]);\nis_deeply([sqrtmod_all(2754, 6561)],   [126, 603, 855, 1332, 1584, 2061, 2313, 2790, 3042, 3519, 3771, 4248, 4500, 4977, 5229, 5706, 5958, 6435]);\nis_deeply([sqrtmod_all(17640, 48465)], [2865, 7905, 8250, 13290, 19020, 24060, 24405, 29445, 35175, 40215, 40560, 45600]);\n#>>>\n\nis_deeply([sqrtmod_all(-1, 13**18 * 5**7)],\n          [633398078861605286438568, 2308322911594648160422943, 6477255756527023177780182, 8152180589260066051764557]);\n"
  },
  {
    "path": "Math/multi_sqrt_nums.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n\nuse 5.010;\n\nmy $format = \"%20s ** %-20s = %s\\n\";\n\nfor my $x (2 .. 10) {\n    for my $y (2 .. 10) {\n        my $num = $x**$y;\n\n        printf($format, $x, $y, $num);\n\n        my $sqrt = $num;\n        for (1 .. $y - 1) {\n            $sqrt = sqrt($sqrt);\n        }\n        my $pow = 2**int($y - 1) / $y;\n        printf($format, $sqrt, $pow, $sqrt**$pow);\n        say \"-\" x 80;\n    }\n}\n"
  },
  {
    "path": "Math/multinomial_coefficient.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 01 February 2018\n# https://github.com/trizen\n\n# Simple algorithm for computing the multinomial coefficient, using prime powers.\n\n# See also:\n#   https://mathworld.wolfram.com/MultinomialCoefficient.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(forprimes vecsum);\nuse Math::AnyNum qw(:overload sumdigits);\n\nsub factorial_power ($n, $p) {\n    ($n - sumdigits($n, $p)) / ($p - 1);\n}\n\nsub multinomial (@mset) {\n\n    my $sum  = vecsum(@mset);\n    my $prod = 1;\n    my $end  = $#mset;\n\n    forprimes {\n        my $p = $_;\n        my $e = factorial_power($sum, $p);\n\n        for (my $i = $end ; $i >= 0 ; --$i) {\n\n            my $n = $mset[$i];\n\n            if ($p <= $n) {\n                $e -= factorial_power($n, $p);\n            }\n            else {\n                splice(@mset, $i, 1), --$end;\n            }\n        }\n\n        $prod *= $p**$e;\n    } $sum;\n\n    return $prod;\n}\n\nsay multinomial(7, 2, 5, 2, 12, 11);    # 440981754363423854380800\n"
  },
  {
    "path": "Math/multinomial_coefficient_from_binomial.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 04 February 2018\n# https://github.com/trizen\n\n# Identity for computing the multinomial coefficient using binomial coefficients.\n\n# See also:\n#   https://mathworld.wolfram.com/MultinomialCoefficient.html\n#   https://en.wikipedia.org/wiki/Multinomial_theorem\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload binomial);\n\nsub multinomial (@mset) {\n\n    my $prod = 1;\n    my $n    = shift(@mset);\n\n    foreach my $k (@mset) {\n        $prod *= binomial($n += $k, $k);\n    }\n\n    return $prod;\n}\n\nsay multinomial(7, 2, 5, 2, 12, 11);    # 440981754363423854380800\n"
  },
  {
    "path": "Math/multiplicative_partitions.pl",
    "content": "#!/usr/bin/perl\n\n# Generate all sets of integers >= 2 whose product equals n.\n\n# See also:\n#   https://oeis.org/A001055 -- The multiplicative partition function\n#   https://oeis.org/A162247 -- Irregular triangle in which row n lists all factorizations of n\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\n\nsub multiplicative_partitions($n, $max_part = $n) {\n\n    my @results;\n    my @divs = divisors($n);\n\n    shift(@divs);    # remove divisor '1'\n\n    my $end = $#divs;\n    my @path;\n\n    sub ($target, $min_idx) {\n\n        if ($target == 1) {\n            push @results, [@path];\n            return;\n        }\n\n        for my $i ($min_idx .. $end) {\n            my $d = $divs[$i];\n\n            # Prune branch if the divisor exceeds the remaining target\n            last if $d > $target;\n            last if $d > $max_part;\n\n            if ($target % $d == 0) {\n                push @path, $d;\n                __SUB__->(divint($target, $d), $i);\n                pop @path;\n            }\n        }\n    }->($n, 0);\n\n    @results = sort { @$a <=> @$b } @results;\n\n    return @results;\n}\n\n# --- Execution and Output ---\nmy $n            = shift(@ARGV) // 48;\nmy $max_part     = shift(@ARGV) // $n;\nmy @combinations = multiplicative_partitions($n, $max_part);\n\n# Format and print the output\nmy @formatted;\nfor my $combo (@combinations) {\n    push @formatted, \"[\" . join(\", \", @$combo) . \"]\";\n}\n\nprint \"For n = $n, we have:\\n\" . join(\"\\n\", @formatted) . \"\\n\";\n\n__END__\nFor n = 48, we have:\n[48]\n[2, 24]\n[3, 16]\n[4, 12]\n[6, 8]\n[2, 2, 12]\n[2, 3, 8]\n[2, 4, 6]\n[3, 4, 4]\n[2, 2, 2, 6]\n[2, 2, 3, 4]\n[2, 2, 2, 2, 3]\n"
  },
  {
    "path": "Math/multisets.pl",
    "content": "#!/usr/bin/perl\n\n# Generate Combinations with Replacement (also known as multisets) of size `n`, with maximum value `k` and maximum sum `max_sum`.\n\nuse 5.036;\n\nsub multisets ($n, $k, $max_sum) {\n    my @result;\n    my @path;\n\n    sub ($pos, $max_val, $sum) {\n\n        if ($pos == $n) {\n            push @result, [@path];\n            return;\n        }\n\n        for my $v (1 .. $max_val) {\n            last if ($sum + $v > $max_sum);\n            push @path, $v;\n            __SUB__->($pos + 1, $v, $sum + $v);\n            pop @path;\n        }\n    }->(0, $k, 0);\n\n    return @result;\n}\n\n# Print results\nmy ($n, $k, $max_sum) = (3, 4, 8);\nmy @perms = multisets($n, $k, $max_sum);\nfor my $perm (@perms) {\n    print \"[\" . join(\", \", @$perm) . \"]\\n\";\n}\n\n__END__\n[1, 1, 1]\n[2, 1, 1]\n[2, 2, 1]\n[2, 2, 2]\n[3, 1, 1]\n[3, 2, 1]\n[3, 2, 2]\n[3, 3, 1]\n[3, 3, 2]\n[4, 1, 1]\n[4, 2, 1]\n[4, 2, 2]\n[4, 3, 1]\n"
  },
  {
    "path": "Math/multivariate_gamma_function.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 03 October 2017\n# https://github.com/trizen\n\n# A simple implementation of the multivariate gamma function.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Multivariate_gamma_function\n\nuse 5.014;\nuse warnings;\n\nuse Math::AnyNum qw(pi gamma);\n\nsub multivariate_gamma {\n    my ($n, $p) = @_;\n\n    my $prod = 1;\n    foreach my $j (1 .. $p) {\n        $prod *= gamma($n + (1 - $j) / 2);\n    }\n\n    $prod * pi**($p * ($p - 1) / 4);\n}\n\nsay multivariate_gamma(10, 5);    # means: gamma_5(10)\n"
  },
  {
    "path": "Math/mysterious_sum-pentagonal_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 14 August 2016\n# License: GPLv3\n# Website: https://github.com/trizen\n\n# Mysterious sum-pentagonal numbers.\n\n# A strange fact: at this very moment, as far as\n# I searched, nothing is known about this numbers...\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Memoize qw(memoize);\n\nmemoize('sum_pentagonal');\n\nsub p {\n    $_[0] * (3 * $_[0] - 1) / 2;\n}\n\nsub sum_pentagonal {\n    my ($n) = @_;\n\n    my $i   = 1;\n    my $sum = 0;\n\n    while (1) {\n        my $p1 = p($i);\n\n        if ($n - $p1 == 0) {\n            return $sum + $n;\n        }\n        elsif ($n - $p1 < 0) {\n            last;\n        }\n\n        $sum += (-1)**($i - 1) * sum_pentagonal($n - $p1);\n\n        my $p2 = p(-$i);\n\n        if ($n - $p2 == 0) {\n            return $sum + $n;\n        }\n        elsif ($n - $p2 < 0) {\n            last;\n        }\n\n        $sum += (-1)**($i - 1) * sum_pentagonal($n - $p2);\n\n        ++$i;\n    }\n\n    $sum;\n}\n\nforeach my $n (1 .. 100) {\n    say \"s($n) = \", sum_pentagonal($n);\n}\n\n__END__\ns(1) = 1\ns(2) = 3\ns(3) = 4\ns(4) = 7\ns(5) = 16\ns(6) = 22\ns(7) = 42\ns(8) = 59\ns(9) = 91\ns(10) = 130\ns(11) = 192\ns(12) = 276\ns(13) = 388\ns(14) = 534\ns(15) = 752\ns(16) = 1011\ns(17) = 1376\ns(18) = 1833\ns(19) = 2448\ns(20) = 3216\ns(21) = 4232\ns(22) = 5514\ns(23) = 7152\ns(24) = 9206\ns(25) = 11823\ns(26) = 15094\ns(27) = 19198\ns(28) = 24282\ns(29) = 30624\ns(30) = 38450\n"
  },
  {
    "path": "Math/mysterious_sum-pentagonal_numbers_2.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 14 August 2016\n# License: GPLv3\n# Website: https://github.com/trizen\n\n# Mysterious sum-pentagonal numbers of second order.\n# A strange fact: at this very moment, nothing is known about this numbers...\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Memoize qw(memoize);\n\nmemoize('sum_pentagonal');\n\n# Tip: square numbers also produce a nice sequence.\n\nsub p {\n    $_[0] * (3 * $_[0] - 1) / 2;\n}\n\nsub f1 {\n    my ($n, $i) = @_;\n\n    my $p = p($i);\n\n    return $n if $n - $p == 0;\n    return 0  if $n - $p < 0;\n\n    (-1)**($i + 1) * f1($n - $p, $i - 1) + sum_pentagonal($n - 1);\n}\n\nsub f2 {\n    my ($n, $i) = @_;\n\n    my $p = p($i);\n\n    return $n if $n - $p == 0;\n    return 0  if $n - $p < 0;\n\n    (-1)**($i + 1) * f2($n - $p, $i - 1) + sum_pentagonal($n - 1);\n}\n\nsub sum_pentagonal {\n    my ($n) = @_;\n    f1($n, 1) + f2($n, -1);\n}\n\nforeach my $n (1 .. 50) {\n    say \"s($n) = \", sum_pentagonal($n);\n}\n\n__END__\ns(1) = 1\ns(2) = 3\ns(3) = 5\ns(4) = 10\ns(5) = 20\ns(6) = 40\ns(7) = 80\ns(8) = 160\ns(9) = 327\ns(10) = 727\ns(11) = 1534\ns(12) = 3235\ns(13) = 6870\ns(14) = 14547\ns(15) = 30795\ns(16) = 65225\ns(17) = 138127\ns(18) = 292502\ns(19) = 619434\ns(20) = 1311770\ns(21) = 2777915\ns(22) = 5882762\ns(23) = 12457860\ns(24) = 26381850\ns(25) = 55837767\ns(26) = 118216202\ns(27) = 250283492\ns(28) = 529868526\ns(29) = 1121788555\ns(30) = 2374952064\n"
  },
  {
    "path": "Math/n_dimensional_circles.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 20 November 2015\n# Website: https://github.com/trizen\n\n# The area of a circle in n-dimensions:\n#   pi * d^n / (2*n)\n#   pi * r^n * 2^(n-1) / n\n\n# The circumference of a circle in n-dimensions:\n#   pi * d^(n-1)\n#   pi * r^(n-1) * 2^(n-1)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Text::ASCIITable;\n\nmy @d_areas;\nmy @r_areas;\n\nmy @d_circumferences;\nmy @r_circumferences;\n\nfor my $i (1 .. 9) {\n    push @d_areas, sprintf(\"pi * d^%d / %s\", $i, 2 * $i);\n    push @r_areas, sprintf(\"pi * r^%d * %d/%d\", $i, 2**($i - 1), $i);\n    push @d_circumferences, sprintf(\"pi * d^%d\", $i - 1);\n    push @r_circumferences, sprintf(\"pi * r^%d * %d\", $i - 1, 2**($i - 1));\n}\n\nmy $table = Text::ASCIITable->new;\n$table->setCols('Dimension', 'Volume (d)', 'Volume (r)', 'Perimeter (d)', 'Perimeter (r)');\n\nforeach my $i (0 .. $#d_areas) {\n    $table->addRow($i + 1, $d_areas[$i], $r_areas[$i], $d_circumferences[$i], $r_circumferences[$i]);\n}\n\nprint $table;\n\n__END__\n.-------------------------------------------------------------------------------.\n| Dimension | Volume (d)    | Volume (r)       | Perimeter (d) | Perimeter (r)  |\n+-----------+---------------+------------------+---------------+----------------+\n|         1 | pi * d^1 / 2  | pi * r^1 * 1/1   | pi * d^0      | pi * r^0 * 1   |\n|         2 | pi * d^2 / 4  | pi * r^2 * 2/2   | pi * d^1      | pi * r^1 * 2   |\n|         3 | pi * d^3 / 6  | pi * r^3 * 4/3   | pi * d^2      | pi * r^2 * 4   |\n|         4 | pi * d^4 / 8  | pi * r^4 * 8/4   | pi * d^3      | pi * r^3 * 8   |\n|         5 | pi * d^5 / 10 | pi * r^5 * 16/5  | pi * d^4      | pi * r^4 * 16  |\n|         6 | pi * d^6 / 12 | pi * r^6 * 32/6  | pi * d^5      | pi * r^5 * 32  |\n|         7 | pi * d^7 / 14 | pi * r^7 * 64/7  | pi * d^6      | pi * r^6 * 64  |\n|         8 | pi * d^8 / 16 | pi * r^8 * 128/8 | pi * d^7      | pi * r^7 * 128 |\n|         9 | pi * d^9 / 18 | pi * r^9 * 256/9 | pi * d^8      | pi * r^8 * 256 |\n'-----------+---------------+------------------+---------------+----------------'\n"
  },
  {
    "path": "Math/near-power_factorization_method.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 03 June 2019\n# https://github.com/trizen\n\n# A simple factorization method for numbers close to a perfect power.\n\n# Very effective for numbers of the form:\n#\n#   n^k - 1\n#\n# where k has many divisors.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Math::GMPz;\nuse ntheory qw(divisors is_power gcd powint rootint vecprod);\n\nsub near_power_factorization ($n, $bound = 10000) {\n\n    if (ref($n) ne 'Math::GMPz') {\n        $n = Math::GMPz->new(\"$n\");\n    }\n\n    my $orig = $n;\n\n    my $f = sub ($r, $e, $k) {\n\n        my @factors;\n\n        foreach my $d (divisors($e)) {\n            foreach my $j (1, -1) {\n\n                my $t = $r**$d - $k * $j;\n                my $g = gcd($t, $n);\n\n                if ($g > 1 and $g < $n) {\n                    while ($n % $g == 0) {\n                        $n /= $g;\n                        push @factors, $g;\n                    }\n                }\n            }\n        }\n\n        push @factors, $orig / vecprod(@factors);\n        return sort { $a <=> $b } @factors;\n    };\n\n    foreach my $j (1 .. $bound) {\n        foreach my $k (1, -1) {\n\n            my $u = $k * $j * $j;\n\n            if ($n + $u > 0) {\n                if (my $e = is_power($n + $u)) {\n                    my $r = Math::GMPz->new(rootint($n + $u, $e));\n                    return $f->($r, $e, $j);\n                }\n            }\n        }\n    }\n\n    return $n;\n}\n\nif (@ARGV) {\n    say join ', ', near_power_factorization($ARGV[0], defined($ARGV[1]) ? $ARGV[1] : ());\n    exit;\n}\n\nsay join ' * ', near_power_factorization(powint(2,  256) - 1);\nsay join ' * ', near_power_factorization(powint(10, 120) + 1);\nsay join ' * ', near_power_factorization(powint(10, 120) - 1);\nsay join ' * ', near_power_factorization(powint(10, 120) - 25);\nsay join ' * ', near_power_factorization(powint(10, 105) - 1);\nsay join ' * ', near_power_factorization(powint(10, 105) + 1);\nsay join ' * ', near_power_factorization(powint(10, 120) - 2134 * 2134);\n\n__END__\n3 * 5 * 17 * 257 * 65537 * 4294967297 * 18446744073709551617 * 340282366920938463463374607431768211457\n100000001 * 9999999900000001 * 99999999000000009999999900000001 * 10000000099999999999999989999999899999999000000000000000100000001\n3 * 9 * 11 * 37 * 91 * 101 * 9091 * 9901 * 10001 * 11111 * 90090991 * 99009901 * 99990001 * 109889011 * 9999000099990001 * 10099989899000101 * 100009999999899989999000000010001\n3 * 5 * 5 * 29 * 2298850574712643678160919540229885057471264367816091954023 * 199999999999999999999999999999999999999999999999999999999999\n9 * 111 * 11111 * 1111111 * 90090991 * 900900990991 * 900009090090909909099991 * 1109988789001111109989898989900111110998878900111\n11 * 91 * 9091 * 909091 * 769223077 * 156985855573 * 1099988890111109888900011 * 910009191000909089989898989899909091000919100091\n3 * 7 * 7 * 36 * 61 * 167280026764804282368685178989628638340582134493141518903 * 18518518518518518518518518518518518518518518518518518518479\n"
  },
  {
    "path": "Math/newton_s_method.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 01 October 2016\n# Website: https://github.com/trizen\n\n# Approximate nth-roots using Newton's method.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload);\n\nsub nth_root {\n    my ($n, $x) = @_;\n\n    my $eps = 10**-($Math::AnyNum::PREC >> 2);\n\n    my $r = 0.0;\n    my $m = 1.0;\n\n    while (abs($m - $r) > $eps) {\n        $r = $m;\n        $m = (($n - 1) * $r + $x / $r**($n - 1)) / $n;\n    }\n\n    $r;\n}\n\nsay nth_root(2,  2);\nsay nth_root(3,  125);\nsay nth_root(7,  42**7);\nsay nth_root(42, 987**42);\n"
  },
  {
    "path": "Math/newton_s_method_recursive.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 18 July 2016\n# Website: https://github.com/trizen\n\n# Newton's method -- recursive\n\n# x^(1/n) = f(k)    ; with k -> infinity.\n\n# where f(k) is defined as:\n# | f(1) = 1\n# | f(k) = (f(k-1) * (n-1) + x / f(k-1)^(n-1)) / n\n\n# Alternatively, f(k) can be defined as:\n#  | f(1) = 1\n#  | f(k) = (1 - 1/n) * f(k-1) + x / (n * f(k-1)^(n-1))\n\nuse 5.016;\n\nsub nth_root {\n    my ($n, $x, $k) = @_;\n\n    my $p = $n - 1;\n\n    sub {\n        my $f = (\n                 $_[0] > 1\n                 ? __SUB__->($_[0] - 1)\n                 : return 1\n                );\n\n        ($f * $p + $x / $f**$p) / $n;\n      }\n      ->($k);\n}\n\nsay nth_root(2, 2,    100);    # square root of 2\nsay nth_root(3, 27,   100);    # third root of 27\nsay nth_root(3, 125,  100);    # third root of 125\nsay nth_root(5, 3125, 100);    # fifth root of 3125\n"
  },
  {
    "path": "Math/next_palindrome.pl",
    "content": "#!/usr/bin/perl\n\n# A nice algorithm, due to David A. Corneth (Jun 06 2014), for generating the next palindrome from a given palindrome.\n\n# See also:\n#   https://oeis.org/A002113\n#   https://en.wikipedia.org/wiki/Palindromic_number\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nsub next_palindrome ($n) {\n\n    my @d = split(//, $n);\n    my $l = $#d;\n    my $i = ((scalar(@d) + 1) >> 1) - 1;\n\n    while ($i >= 0 and $d[$i] == 9) {\n        $d[$i] = 0;\n        $d[$l - $i] = 0;\n        $i--;\n    }\n\n    if ($i >= 0) {\n        $d[$i]++;\n        $d[$l - $i] = $d[$i];\n    }\n    else {\n        @d = (0) x (scalar(@d) + 1);\n        $d[0]  = 1;\n        $d[-1] = 1;\n    }\n\n    join('', @d);\n}\n\nmy $n = 1;\nfor (1 .. 100) {    # first 100 palindromes\n    print(\"$n, \");\n    $n = next_palindrome($n);\n}\nsay \"\\n\";\n\nsay next_palindrome(99977999);      #=> 99988999\nsay next_palindrome(99988999);      #=> 99999999\nsay next_palindrome(99999999);      #=> 100000001\n\nsay '';\n\nsay next_palindrome(\"51818186768181815\");    #=> 51818186868181815\nsay next_palindrome(\"51818186868181815\");    #=> 51818186968181815\nsay next_palindrome(\"51818186968181815\");    #=> 51818187078181815\n"
  },
  {
    "path": "Math/next_palindrome_from_non-palindrome.pl",
    "content": "#!/usr/bin/perl\n\n# Generate the next palindrome in a given base, where the input number may not be a palindrome.\n# Algorithm by David A. Corneth (Jun 06 2014), with extensions by Daniel Suteu (Jun 06 2020).\n\n# See also:\n#   https://oeis.org/A002113\n#   https://en.wikipedia.org/wiki/Palindromic_number\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\nuse Test::More tests => 41;\n\nsub next_palindrome ($n, $base = 10) {\n\n    my @d = todigits($n, $base);\n    my $l = $#d;\n    my $i = ((scalar(@d) + 1) >> 1) - 1;\n\n    my $is_palindrome = 1;\n\n    foreach my $j (0 .. $i) {\n        if ($d[$j] != $d[$l - $j]) {\n            $is_palindrome = 0;\n            last;\n        }\n    }\n\n    if (!$is_palindrome) {\n        my @copy = @d;\n\n        foreach my $i (0 .. $i) {\n            $d[$l - $i] = $d[$i];\n        }\n\n        my $is_greater = 1;\n\n        foreach my $j (0 .. $i) {\n            my $cmp = $d[$i + $j + 1] <=> $copy[$i + $j + 1];\n\n            if ($cmp > 0) {\n                last;\n            }\n            if ($cmp < 0) {\n                $is_greater = 0;\n                last;\n            }\n        }\n\n        if ($is_greater) {\n            return fromdigits(\\@d, $base);\n        }\n    }\n\n    while ($i >= 0 and $d[$i] == $base - 1) {\n        $d[$i] = 0;\n        $d[$l - $i] = 0;\n        $i--;\n    }\n\n    if ($i >= 0) {\n        $d[$i]++;\n        $d[$l - $i] = $d[$i];\n    }\n    else {\n        @d     = (0) x (scalar(@d) + 1);\n        $d[0]  = 1;\n        $d[-1] = 1;\n    }\n\n    fromdigits(\\@d, $base);\n}\n\n#\n## Run some tests\n#\n\nmy @palindromes = do {\n    my $x = 0;\n    my @list;\n    for (1 .. 61) {\n        push @list, $x;\n        $x = next_palindrome($x);\n    }\n    @list;\n};\n\nis_deeply(\n          \\@palindromes,\n          [0,   1,   2,   3,   4,   5,   6,   7,   8,   9,   11,  22,  33,  44,  55,  66,  77,  88,  99,  101, 111, 121,\n           131, 141, 151, 161, 171, 181, 191, 202, 212, 222, 232, 242, 252, 262, 272, 282, 292, 303, 313, 323, 333, 343,\n           353, 363, 373, 383, 393, 404, 414, 424, 434, 444, 454, 464, 474, 484, 494, 505, 515\n          ]\n         );\n\nis(next_palindrome(10),    11);\nis(next_palindrome(11),    22);\nis(next_palindrome(12),    22);\nis(next_palindrome(110),   111);\nis(next_palindrome(111),   121);\nis(next_palindrome(112),   121);\nis(next_palindrome(120),   121);\nis(next_palindrome(121),   131);\nis(next_palindrome(1234),  1331);\nis(next_palindrome(12345), 12421);\n\nis(next_palindrome(8887),  8888);\nis(next_palindrome(8888),  8998);\nis(next_palindrome(8889),  8998);\nis(next_palindrome(88887), 88888);\nis(next_palindrome(88888), 88988);\nis(next_palindrome(88889), 88988);\nis(next_palindrome(9998),  9999);\nis(next_palindrome(99998), 99999);\nis(next_palindrome(9999),  10001);\nis(next_palindrome(99999), 100001);\n\nis(next_palindrome(12311), 12321);\nis(next_palindrome(1321),  1331);\nis(next_palindrome(1331),  1441);\nis(next_palindrome(13530), 13531);\nis(next_palindrome(13520), 13531);\nis(next_palindrome(13521), 13531);\nis(next_palindrome(13530), 13531);\nis(next_palindrome(13531), 13631);\nis(next_palindrome(13540), 13631);\nis(next_palindrome(13532), 13631);\n\nis(next_palindrome(1234, 2), 1241);\nis(next_palindrome(1234, 3), 1249);\nis(next_palindrome(1234, 4), 1265);\nis(next_palindrome(1234, 5), 1246);\nis(next_palindrome(1234, 6), 1253);\n\nis(next_palindrome(12345, 2), 12483);\nis(next_palindrome(12345, 3), 12382);\nis(next_palindrome(12345, 4), 12355);\nis(next_palindrome(12345, 5), 12348);\nis(next_palindrome(12345, 6), 12439);\n"
  },
  {
    "path": "Math/next_palindrome_in_base.pl",
    "content": "#!/usr/bin/perl\n\n# A nice algorithm, due to David A. Corneth (Jun 06 2014), for generating the next palindrome from a given palindrome.\n\n# Generalized to other bases by Daniel Suteu (Sep 16 2019).\n\n# See also:\n#   https://oeis.org/A002113\n#   https://en.wikipedia.org/wiki/Palindromic_number\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub next_palindrome ($n, $base = 10) {\n\n    my @d = todigits($n, $base);\n    my $l = $#d;\n    my $i = ((scalar(@d) + 1) >> 1) - 1;\n\n    while ($i >= 0 and $d[$i] == $base - 1) {\n        $d[$i] = 0;\n        $d[$l - $i] = 0;\n        $i--;\n    }\n\n    if ($i >= 0) {\n        $d[$i]++;\n        $d[$l - $i] = $d[$i];\n    }\n    else {\n        @d     = (0) x (scalar(@d) + 1);\n        $d[0]  = 1;\n        $d[-1] = 1;\n    }\n\n    fromdigits(\\@d, $base);\n}\n\nforeach my $base (2 .. 12) {\n    my @a = do {\n        my $n = 1;\n        map { $n = next_palindrome($n, $base) } 1 .. 20;\n    };\n    say \"base = $base -> [@a]\";\n}\n\n__END__\nbase = 2 -> [3 5 7 9 15 17 21 27 31 33 45 51 63 65 73 85 93 99 107 119]\nbase = 3 -> [2 4 8 10 13 16 20 23 26 28 40 52 56 68 80 82 91 100 112 121]\nbase = 4 -> [2 3 5 10 15 17 21 25 29 34 38 42 46 51 55 59 63 65 85 105]\nbase = 5 -> [2 3 4 6 12 18 24 26 31 36 41 46 52 57 62 67 72 78 83 88]\nbase = 6 -> [2 3 4 5 7 14 21 28 35 37 43 49 55 61 67 74 80 86 92 98]\nbase = 7 -> [2 3 4 5 6 8 16 24 32 40 48 50 57 64 71 78 85 92 100 107]\nbase = 8 -> [2 3 4 5 6 7 9 18 27 36 45 54 63 65 73 81 89 97 105 113]\nbase = 9 -> [2 3 4 5 6 7 8 10 20 30 40 50 60 70 80 82 91 100 109 118]\nbase = 10 -> [2 3 4 5 6 7 8 9 11 22 33 44 55 66 77 88 99 101 111 121]\nbase = 11 -> [2 3 4 5 6 7 8 9 10 12 24 36 48 60 72 84 96 108 120 122]\nbase = 12 -> [2 3 4 5 6 7 8 9 10 11 13 26 39 52 65 78 91 104 117 130]\n"
  },
  {
    "path": "Math/next_power_of_two.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 25 December 2012\n# https://github.com/trizen\n\nsub next_power_of_two {\n    return 2 << log($_[0]) / log(2);\n}\n\nfor my $i (1, 31, 55, 129, 446, 9924) {\n    print next_power_of_two($i), \"\\n\";\n}\n"
  },
  {
    "path": "Math/nth_composite.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 22 December 2019\n# https://github.com/trizen\n\n# Compute the n-th composite number and the number of composite numbers <= n.\n\n# See also:\n#   https://oeis.org/A002808 -- The composite numbers: numbers n of the form x*y for x > 1 and y > 1.\n#   https://oeis.org/A065857 -- The (10^n)-th composite number.\n\nuse 5.020;\nuse warnings;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub composite_count($n) {\n    $n - prime_count($n) - 1;\n}\n\nsub nth_composite($n) {\n\n    return undef if ($n <= 0);\n    return 4     if ($n == 1);\n\n    # Lower and upper bounds from A002808 (for n >= 4).\n    my $min = int($n + $n / log($n) + $n / (log($n)**2));\n    my $max = int($n + $n / log($n) + (3 * $n) / (log($n)**2));\n\n    if ($n < 4) {\n        $min = 4;\n        $max = 8;\n    }\n\n    my $k = 0;\n\n    while (1) {\n        $k = ($min + $max) >> 1;\n\n        my $cmp = ($k - prime_count($k) - 1) <=> $n;\n\n        if ($cmp > 0) {\n            $max = $k - 1;\n        }\n        elsif ($cmp < 0) {\n            $min = $k + 1;\n        }\n        else {\n            last;\n        }\n    }\n\n    --$k if is_prime($k);\n\n    return $k;\n}\n\nsay nth_composite(1000000000);      #=> 1053422339\nsay composite_count(1053422339);    #=> 1000000000\n"
  },
  {
    "path": "Math/nth_digit_of_fraction.pl",
    "content": "#!/usr/bin/perl\n\n# An efficient formula for computing the n-th decimal digit of a given fraction expression x/y.\n\n# Formula from:\n#   https://stackoverflow.com/questions/804934/getting-a-specific-digit-from-a-ratio-expansion-in-any-base-nth-digit-of-x-y\n\n# See also:\n#   https://projecteuler.net/problem=820\n\nuse 5.036;\nuse ntheory qw(:all);\n\nsub nth_digit_of_fraction($n, $x, $y, $base = 10) {\n    divint($base * powmod($base, $n - 1, $y) * $x, $y) % $base;\n}\n\nsay vecsum(map { nth_digit_of_fraction(7,   1, $_) } 1 .. 7);      #=> 10\nsay vecsum(map { nth_digit_of_fraction(100, 1, $_) } 1 .. 100);    #=> 418\n"
  },
  {
    "path": "Math/nth_prime_approx.pl",
    "content": "#!/usr/bin/perl\n\n# A messy, but interesting approximation for the nth-prime.\n\n# Formulas from:\n#   https://stackoverflow.com/a/9487883/1063770\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(nth_prime);\n\nmy $sum1 = 0;\nmy $sum2 = 0;\n\nfor (my $n = 1e6 ; $n < 1e7 ; $n += 1e6) {\n    my $p = nth_prime($n);\n\n    # more than good approximation (experimental)\n    my $p1 = int(\n         1 / 2 * (\n             3 - (8 + log(2.3)) * $n - $n**2 + 1 / 2 * (\n                            -1 + abs(\n                                -(1 / 2) + $n + sqrt(\n                                    log(log($n) / log(2)) *\n                                      (-log(log(2)) + log(log($n)) + (8 * log(3) * log(($n * log(8 * $n)) / log($n))) / log(2))\n                                  ) / (2 * log(log(($n * log(8 * $n)) / log($n)) / log(2)))\n                              ) + abs(log($n) / log(3) + log(log(($n * log(8 * $n)) / log($n)) / log(2)) / log(2))\n               ) * (\n                 2 * abs(log(($n * log(8 * $n)) / log($n)) / log(3) + log(log(($n * log(8 * $n)) / log($n)) / log(2)) / log(2))\n                   + abs(\n                         1 / log(log($n) / log(2)) * (\n                                 log(log(3)) - log(log($n)) + 2 * $n * log(log($n) / log(2)) + sqrt(\n                                     ((8 * log(3) * log($n)) / log(2) - log(log(2)) + log(log(($n * log(8 * $n)) / log($n)))) *\n                                       log(log(($n * log(8 * $n)) / log($n)) / log(2))\n                                 )\n                         )\n                        )\n                   )\n                 )\n                );\n\n    # good approximation\n    my $p2 = int(\n                 1 / 2 * (\n                     8 - 8.7 * $n - $n**2 + 1 / 2 * (\n                         2 * abs(log($n) / log(3) + log(log($n) / log(2)) / log(2)) + abs(\n                             (\n                              log(log(3)) -\n                                log(log($n)) +\n                                2 * $n * log(log($n) / log(2)) +\n                                sqrt(((8 * log(3) * log($n)) / log(2) - log(log(2)) + log(log($n))) * log(log($n) / log(2)))\n                             ) / log(log($n) / log(2))\n                         )\n                       ) * (\n                           -1 + abs(log($n) / log(3) + log(log($n) / log(2)) / log(2)) + abs(\n                               -(1 / 2) +\n                                 $n +\n                                 sqrt(((8 * log(3) * log($n)) / log(2) - log(log(2)) + log(log($n))) * log(log($n) / log(2))) /\n                                 (2 * log(log($n) / log(2)))\n                           )\n                       )\n                 )\n                );\n\n    $sum1 += $p / $p1;\n    $sum2 += $p / $p2;\n\n    say \"P($n) -> \",join(\" \", sprintf(\"%10s\" x 3, $p, $p1, $p2), \"\\t\", sprintf(\"%.5f\", $p / $p1), sprintf(\"%.5f\", $p / $p2));\n}\n\nsay \"P1 error: $sum1\";\nsay \"P2 error: $sum2\";\n\n__END__\n        29        36        29   0.80556 1.00000\n  15486041  15457742  15439431   1.00183 1.00302\n  32453039  32433008  32405572   1.00062 1.00146\n  49979893  49975183  49941439   1.00009 1.00077\n  67868153  67884333  67846000   0.99976 1.00033\n  86028343  86065798  86024104   0.99956 1.00005\n 104395451 104463936 104419831   0.99934 0.99977\n 122950039 123042040 122996293   0.99925 0.99962\n 141651127 141774052 141727310   0.99913 0.99946\n 160481437 160640508 160593326   0.99901 0.99930\n\nP1 error: 9.80416402659991\nP2 error: 10.0037856546587\n"
  },
  {
    "path": "Math/nth_root_good_rational_approximations.pl",
    "content": "#!/usr/bin/perl\n\n# Formula for computing good rational approximations to the n-th root of a number.\n\n# See also:\n#   https://www.mathpages.com/home/kmath434.htm\n\nuse 5.014;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload iroot sum binomial);\n\nsub f ($N, $r) {\n\n    my $m = iroot($N, $r);\n    my $R = $N - $m**$r;\n\n    my @s = ((0) x ($r - 1), 1);\n\n    return (\n        $m, $R,\n        sub ($n) {\n            $s[$n] //= sum(map { my $j = $_; binomial($r, $j) * $m**($r - $j) * $R**($j - 1) * $s[$n - $j] } 1 .. $r);\n        }\n    );\n}\n\nmy ($m, $R, $g) = f(10, 3);     # approximations for 10^(1/3)\n\nforeach my $n (1 .. 20) {\n\n    my $x = $g->($n);\n    my $y = $g->($n + 1);\n\n    my $t = ($m + $R * $x / $y);\n\n    printf(\"%20s / %-20s =~ %s\\n\", $t->nude, $t->as_dec);\n}\n\n__END__\n                   2 / 1                    =~ 2\n                  13 / 6                    =~ 2.16666666666666666666666666666666666666666666667\n                  28 / 13                   =~ 2.15384615384615384615384615384615384615384615385\n                1088 / 505                  =~ 2.15445544554455445544554455445544554455445544554\n                1409 / 654                  =~ 2.1544342507645259938837920489296636085626911315\n                7603 / 3529                 =~ 2.15443468404647208841031453669594786058373476906\n              590774 / 274213               =~ 2.15443469128013624445230532469284826029400502529\n             3825397 / 1775592              =~ 2.15443468995129511734677786338302943468995129512\n             2752258 / 1277485              =~ 2.15443469003549943834956966226609314395080959855\n            64157404 / 29779229             =~ 2.15443469003176677273948227470899263375824807284\n          2077169449 / 964136652            =~ 2.1544346900318856460193985032735795215883982388\n          1120845673 / 520250476            =~ 2.15443469003188379591218288476875896217344354722\n        174185580626 / 80849784601          =~ 2.1544346900318837127732819746711696004361257185\n       1127891541661 / 523520878530         =~ 2.15443469003188372228223079040300983199070198122\n        486890409328 / 225994508713         =~ 2.1544346900318837217374632236690845669751527933\n      94581808509632 / 43900986624121       =~ 2.15443469003188372175993267421075826039322542243\n     612438879438973 / 284268946407426      =~ 2.15443469003188372175928686483574181826893273791\n       5954477565019 / 2763823657579        =~ 2.15443469003188372175929288136249910595910099978\n   51357399784775318 / 23837993336440045    =~ 2.15443469003188372175929362914637034425598873999\n   66510185987581361 / 30871293660146676    =~ 2.15443469003188372175929356318484885473783216603\n"
  },
  {
    "path": "Math/nth_root_recurrence_constant.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 10 May 2016\n# Website: https://github.com/trizen\n\n# Compute the nth root recurrence constant (n * (n * (n * (n * ...)^(1/4))^(1/3))^(1/2))\n# See also: https://en.wikipedia.org/wiki/Somos%27_quadratic_recurrence_constant\n\nuse 5.010;\nuse strict;\n\nsub root_const {\n    my ($n, $limit) = @_;\n    $limit > 0 ? ($n * root_const($n+1, $limit-1))**(1/$n) : 1;\n}\n\nsay root_const(1, 30000);\n"
  },
  {
    "path": "Math/nth_smooth_number.pl",
    "content": "#!/usr/bin/perl\n\n# Generate the n-th smooth number that is the product of a given subset of primes.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Smooth_number\n\nuse 5.020;\nuse warnings;\n\nuse ntheory qw(vecmin);\nuse experimental qw(signatures);\n\nsub smooth_generator ($primes) {\n\n    my @s = map { [1] } @$primes;\n\n    sub {\n        my $n = vecmin(map { $_->[0] } @s);\n\n        for my $i (0..$#$primes) {\n            shift(@{$s[$i]}) if ($s[$i][0] == $n);\n            push(@{$s[$i]}, $n*$primes->[$i]);\n        }\n        return $n;\n    };\n}\n\nsub nth_smooth_number($n, $primes) {\n    my $g = smooth_generator($primes);\n    $g->() for (1..$n-1);\n    $g->();\n}\n\nsay nth_smooth_number( 12, [2,7,13,19]);\nsay nth_smooth_number( 25, [2,5,7,11,13,23,29,31,53,67,71,73,79,89,97,107,113,127,131,137]);\nsay nth_smooth_number(500, [7,19,29,37,41,47,53,59,61,79,83,89,101,103,109,127,131,137,139,157,167,179,181,199,211,229,233,239,241,251]);\n"
  },
  {
    "path": "Math/number2expression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 02 May 2022\n# https://github.com/trizen\n\n# Compress a number into a polynomial expression in a given base.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::Sidef qw(Polynomial Number sum);\nuse Math::AnyNum qw(:overload digits);\nuse Getopt::Long qw(GetOptions);\n\nuse ntheory qw(vecsum todigits);\nuse experimental qw(signatures);\n\nsub run_length ($arr, $max_len = 1e9) {\n\n    @$arr || return;\n\n    my @result     = ([$arr->[0], 1]);\n    my $prev_value = $arr->[0];\n\n    foreach my $i (1 .. $#{$arr}) {\n\n        my $curr_value = $arr->[$i];\n\n        if ($curr_value == $prev_value) {\n            ++$result[-1][1];\n        }\n        else {\n            push(@result, [$curr_value, 1]);\n\n            # Stop early when there are too many entries\n            if (scalar(@result) > $max_len) {\n                return @result;\n            }\n        }\n\n        $prev_value = $curr_value;\n    }\n\n    return @result;\n}\n\nsub number2runLength ($n, $base = 10, $max_len = 1e9) {\n    my @D = ($base < 2147483647) ? todigits($n, $base) : reverse(digits($n, $base));\n    my $t = scalar(@D);\n    my @R = run_length(\\@D, $max_len);\n    return \\@R;\n}\n\nsub number2expr ($R, $base = 10) {\n\n    my $t = vecsum(map { $_->[1] } @$R);\n\n    my @terms;\n\n    foreach my $pair (@$R) {\n        my ($d, $l) = @$pair;\n        $t -= $l;\n        push @terms,\n          (\n            ($l == 1)\n            ? Polynomial($t => $d)\n            : Polynomial($l)->sub(Number(1))->div(Number($base - 1))->mul(Polynomial($t => $d))\n          );\n    }\n\n    my $str = sum(@terms)->to_s;\n    ## $str =~ s/x/$base/g;\n    return $str;\n}\n\nsub number2expr_alt ($R, $base = 10) {\n\n    my $t = vecsum(map { $_->[1] } @$R);\n\n    my @terms;\n\n    foreach my $pair (@$R) {\n        my ($d, $l) = @$pair;\n        $t -= $l;\n        push @terms, Polynomial($l)->sub(Number(1))->mul(Polynomial($t => $d));\n    }\n\n    my $sum = sum(@terms);\n\n    my $str = $sum->to_s;\n    if ($base != 2) {\n        $str = \"($str)/\" . ($base - 1);\n    }\n\n    ## $str =~ s/x/$base/g;\n    return $str;\n}\n\nsub compress_number ($n, $from = 2, $upto = 100, $integer_coeff = 0) {\n\n    my $min_runLength = [];\n    my $min_base      = 0;\n    my $min_len       = 1e9;\n\n    foreach my $base ($from .. $upto) {\n\n        my $R = number2runLength($n, $base, $min_len);\n\n        if (scalar(@$R) < $min_len) {\n            $min_len       = scalar(@$R);\n            $min_base      = $base;\n            $min_runLength = $R;\n            last if ($min_len == 1);\n        }\n    }\n\n    my $min_expr     = '';\n    my $min_expr_len = 1e9;\n\n    foreach my $base ($min_base) {\n        my @list;\n\n        push(@list, number2expr($min_runLength, $base)) if !$integer_coeff;\n        push(@list, number2expr_alt($min_runLength, $base));\n\n        foreach my $expr (@list) {\n\n            if (length($expr) < $min_expr_len) {\n                $min_expr     = $expr;\n                $min_expr_len = length($expr);\n            }\n        }\n    }\n\n    $min_expr =~ s/x/$min_base/gr;\n}\n\nsub help {\n    print <<\"EOT\";\nusage: $0 [options] [integer]\n\noptions:\n\n    -f  --from=i     : first base to check\n    -t  --to=i       : last base to check\n    -i  --int!       : prefer integer coefficients\n    -b  --base=i     : use only this specific base\n\nexample:\n\n    perl number2expr.pl 123123123\n    perl number2expr.pl -i -b=1000 123123123\n    perl number2expr.pl -from=900 -to=1200 123123123\n    perl number2expr.pl -i -from=900 -to=1200 123123123\nEOT\n\n    exit 0;\n}\n\nmy $base          = undef;\nmy $from          = 2;\nmy $upto          = 1000;\nmy $integer_coeff = 0;\n\nGetOptions(\n           'b|base=i' => \\$base,\n           'from=i'   => \\$from,\n           'to=i'     => \\$upto,\n           'i|int!'   => \\$integer_coeff,\n           'h|help'   => \\&help,\n          )\n  or die(\"Error in command line arguments\\n\");\n\nforeach my $n (@ARGV) {\n\n    if (defined($base)) {\n        if ($integer_coeff) {\n            say number2expr_alt(number2runLength($n, $base), $base);\n        }\n        else {\n            say number2expr(number2runLength($n, $base), $base);\n        }\n        next;\n    }\n\n    say compress_number($n, $from, $upto, $integer_coeff);\n}\n\nif (!@ARGV) {\n\n#<<<\n    my @tests = (\n        [0b100000100000111111101, 2],\n        [(7**911 - 4 * (7**455) - 1), 7],\n        [11113338888999999999, 10],\n    );\n#>>>\n\n    foreach my $pair (@tests) {\n        my ($n, $b) = @$pair;\n        say(\"base $b: \", number2expr(number2runLength($n, $b), $b));\n        say(\"base $b: \", number2expr_alt(number2runLength($n, $b), $b));\n        say '';\n    }\n}\n\n__END__\nbase 2: x^20 + x^14 + x^9 - x^2 + 1\nbase 2: x^21 - x^20 + x^15 - x^14 + x^9 - x^2 + x - 1\n\nbase 7: x^911 - x^456 + 3*x^455 - 1\nbase 7: (6*x^911 - 4*x^456 + 4*x^455 - 6)/6\n\nbase 10: 1/9*x^20 + 2/9*x^16 + 5/9*x^13 + 1/9*x^9 - 1\nbase 10: (x^20 + 2*x^16 + 5*x^13 + x^9 - 9)/9\n"
  },
  {
    "path": "Math/number_of_conditional_GCDs.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 04 July 2018\n# https://github.com/trizen\n\n# Find the number of k = 1..n for which GCD(n,k) satisfies a certain condition (e.g.:\n# GCD(n,k) is a prime number), using the divisors of `n` and the Euler totient function.\n\n# See also:\n#   https://oeis.org/A117494 -- Number of k = 1..n for which GCD(n, k) is a prime\n#   https://oeis.org/A116512 -- Number of k = 1..n for which GCD(n, k) is a power of a prime\n#   https://oeis.org/A206369 -- Number of k = 1..n for which GCD(n, k) is a square\n#   https://oeis.org/A078429 -- Number of k = 1..n for which GCD(n, k) is a cube\n#   https://oeis.org/A063658 -- Number of k = 1..n for which GCD(n, k) is divisible by a square greater than 1\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(divisors euler_phi is_prime is_square is_prime_power factorial);\n\nsub conditional_euler_totient ($n, $condition) {\n\n    my $count = 0;\n\n    foreach my $d (divisors($n)) {\n        if ($condition->($d)) {\n            $count += euler_phi($n / $d);\n        }\n    }\n\n    return $count;\n}\n\nsay \"Number of values of k with 1 <= k <= n such that gcd(n, k) is a prime number\";\nsay conditional_euler_totient(factorial(10), sub ($d) { is_prime($d) });    # 995328\nsay conditional_euler_totient(factorial(11), sub ($d) { is_prime($d) });    # 10782720\nsay conditional_euler_totient(factorial(12), sub ($d) { is_prime($d) });    # 129392640\n\nsay '';\n\nsay \"Number of values of k with 1 <= k <= n such that gcd(n, k) is a square\";\nsay conditional_euler_totient(factorial(10), sub ($d) { is_square($d) });    # 1314306\nsay conditional_euler_totient(factorial(11), sub ($d) { is_square($d) });    # 13143060\nsay conditional_euler_totient(factorial(12), sub ($d) { is_square($d) });    # 156625560\n\nsay '';\n\nsay \"Number of values of k with 1 <= k <= n such that gcd(n, k) is a prime power\";\nsay conditional_euler_totient(factorial(10), sub ($d) { is_prime_power($d) });    # 1589760\nsay conditional_euler_totient(factorial(11), sub ($d) { is_prime_power($d) });    # 16727040\nsay conditional_euler_totient(factorial(12), sub ($d) { is_prime_power($d) });    # 200724480\n"
  },
  {
    "path": "Math/number_of_connected_permutations.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 03 December 2017\n# https://github.com/trizen\n\n# A new algorithm for computing number of connected permutations of [1..n].\n\n# See also:\n#   https://oeis.org/A003319\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload factorial binomial);\n\nsub number_of_connected_permutations {\n    my ($n) = @_;\n\n    my @P = (1);\n\n    foreach my $i (1 .. $n) {\n        foreach my $k (0 .. $i - 1) {\n            $P[$i] += $P[$k] / binomial($i, $k+1);\n        }\n    }\n\n    map { $P[$_] * factorial($_) } 0 .. $#P;\n}\n\nmy @P = number_of_connected_permutations(20);\n\nforeach my $i (0 .. $#P) {\n    say \"P($i) = $P[$i]\";\n}\n\n__END__\nP(0) = 1\nP(1) = 1\nP(2) = 3\nP(3) = 13\nP(4) = 71\nP(5) = 461\nP(6) = 3447\nP(7) = 29093\nP(8) = 273343\nP(9) = 2829325\nP(10) = 31998903\nP(11) = 392743957\nP(12) = 5201061455\nP(13) = 73943424413\nP(14) = 1123596277863\nP(15) = 18176728317413\nP(16) = 311951144828863\nP(17) = 5661698774848621\nP(18) = 108355864447215063\nP(19) = 2181096921557783605\nP(20) = 46066653228356851631\n"
  },
  {
    "path": "Math/number_of_partitions_into_2_distinct_positive_cubes.pl",
    "content": "#!/usr/bin/perl\n\n# Count the number of partitions of n into 2 distinct positive cubes.\n\n# See also:\n#   https://oeis.org/A025468\n#   https://cs.uwaterloo.ca/journals/JIS/VOL6/Broughan/broughan25.pdf\n\nuse 5.020;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\n# Number of solutions to `n = a^3 + b^3, with 0 < a < b.\nsub r2_cubes_positive_distinct ($n) {\n\n    my $count = 0;\n\n    foreach my $d (divisors($n)) {\n\n        my $l = $d*$d - $n/$d;\n        ($l % 3 == 0) || next;\n        my $t = $d*$d - 4*($l/3);\n\n        if ($d*$d*$d >= $n and $d*$d*$d <= 4 * $n and $l >= 3 and $t > 0 and is_square($t)) {\n            ++$count;\n        }\n    }\n\n    return $count;\n}\n\nforeach my $n (1 .. 100) {\n    print(r2_cubes_positive_distinct($n), \", \");\n}\n\n__END__\n0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0\n"
  },
  {
    "path": "Math/number_of_partitions_into_2_distinct_positive_squares.pl",
    "content": "#!/usr/bin/perl\n\n# Count the number of partitions of n into 2 distinct nonzero squares.\n\n# See also:\n#   https://oeis.org/A025441\n#   https://mathworld.wolfram.com/SumofSquaresFunction.html\n#   https://en.wikipedia.org/wiki/Fermat%27s_theorem_on_sums_of_two_squares\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse ntheory qw(:all);\n\n# Number of solutions to `n = a^2 + b^2, with 0 < a < b.\nsub r2_positive_distinct ($n) {\n\n    my $B = 1;\n\n    foreach my $p (factor_exp($n)) {\n\n        my $r = $p->[0] % 4;\n\n        if ($r == 3) {\n            $p->[1] % 2 == 0 or return 0;\n        }\n\n        if ($r == 1) {\n            $B *= $p->[1] + 1;\n        }\n    }\n\n    return ($B >> 1);\n}\n\nforeach my $n(1..100) {\n    print(r2_positive_distinct($n), \", \");\n}\n"
  },
  {
    "path": "Math/number_of_partitions_into_2_nonnegative_cubes.pl",
    "content": "#!/usr/bin/perl\n\n# Count the number partitions of n into 2 nonnegative cubes.\n\n# See also:\n#   https://oeis.org/A025446\n#   https://cs.uwaterloo.ca/journals/JIS/VOL6/Broughan/broughan25.pdf\n\nuse 5.020;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub r2_cubes_partitions($n) {\n\n    my $L = rootint($n-1, 3) + 1;\n    my $U = rootint(4*$n, 3);\n\n    my $count = 0;\n\n    foreach my $m (divisors($n)) {\n        if ($L <= $m and $m <= $U) {\n            my $l = $m*$m - $n/$m;\n            $l % 3 == 0 or next;\n            $l /= 3;\n            is_square($m*$m - 4*$l) && ++$count;\n        }\n    }\n\n    return $count;\n}\n\nforeach my $n (1 .. 100) {\n    print(r2_cubes_partitions($n), \", \");\n}\n\n__END__\n1, 1, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,\n"
  },
  {
    "path": "Math/number_of_partitions_into_2_positive_squares.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 24 September 2019\n# https://github.com/trizen\n\n# Count the number of representations of n as the sum of two non-zero squares, ignoring order and signs (not necesarily distinct).\n\n# See also:\n#   https://oeis.org/A025426 -- Number of partitions of n into 2 nonzero squares.\n#   https://oeis.org/A000161 -- Number of partitions of n into 2 squares.\n#   https://mathworld.wolfram.com/SumofSquaresFunction.html\n#   https://en.wikipedia.org/wiki/Fermat%27s_theorem_on_sums_of_two_squares\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(divisors valuation factor_exp vecsum vecprod);\n\n# Number of solutions to `n = a^2 + b^2, with 0 < a <= b.\nsub r2_positive($n) {\n\n    my $B  = 1;\n    my $a0 = 0;\n\n    if ($n % 2 == 0) {\n        $a0 = valuation($n, 2);\n        $n >>= $a0;\n    }\n\n    foreach my $p (factor_exp($n)) {\n\n        my $r = $p->[0] % 4;\n\n        if ($r == 3) {\n            $p->[1] % 2 == 0 or return 0;\n        }\n\n        if ($r == 1) {\n            $B *= $p->[1] + 1;\n        }\n    }\n\n    ($B % 2 == 0) ? ($B >> 1) : (($B - (-1)**$a0) >> 1);\n}\n\nforeach my $n (1 .. 100) {\n    print(r2_positive($n), \", \");\n}\n\n__END__\n0, 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 0, 1, 0, 0, 0, 1, 1, 0, 1, 0, 0, 0, 0, 1, 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 0, 1, 0, 0, 1, 1, 0, 0, 0, 1, 0, 0, 0, 0, 2, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 2, 0, 0, 1, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 2, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 1, 0, 1,\n"
  },
  {
    "path": "Math/number_of_representations_as_sum_of_3_triangles.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 02 March 2018\n# https://github.com/trizen\n\n# Compute the number of ordered ways of writing `n` as the sum of 3 triangular numbers.\n\n# See also:\n#   https://oeis.org/A008443\n#   https://projecteuler.net/problem=621\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(factor_exp);\nuse experimental qw(signatures);\n\nsub count_sums_of_two_squares ($n) {\n\n    my $count = 4;\n\n    foreach my $p (factor_exp($n)) {\n\n        my $r = $p->[0] % 4;\n\n        if ($r == 3) {\n            $p->[1] % 2 == 0 or return 0;\n        }\n\n        if ($r == 1) {\n            $count *= $p->[1] + 1;\n        }\n    }\n\n    return $count;\n}\n\nsub count_triangular_sums ($n) {\n\n    my $count = 0;\n    my $limit = (sqrt(8 * $n + 1) - 1) / 2;\n\n    for my $u (0 .. $limit) {\n        my $z = ($n - $u * ($u + 1) / 2) * 8 + 1;\n        $count += count_sums_of_two_squares($z + 1);\n    }\n\n    return $count / 4;\n}\n\nsay count_triangular_sums(10**6);           #=> 2106\nsay count_triangular_sums(10**9);           #=> 62760\nsay count_triangular_sums(31415926535);     #=> 263556\n"
  },
  {
    "path": "Math/number_of_representations_as_sum_of_four_squares.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 23 October 2017\n# https://github.com/trizen\n\n# Counting the number of representations for a given number `n` expressed as the sum of four squares.\n\n# Formula:\n#   R(n) = 8 * Sum_{d | n, d != 0 (mod 4)} d\n\n# See also:\n#   https://oeis.org/A000118\n#   https://en.wikipedia.org/wiki/Lagrange's_four-square_theorem\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(is_prime divisor_sum);\n\nsub count_representations_as_four_squares($n) {\n\n    my $count = 8 * divisor_sum($n);\n\n    if ($n % 4 == 0) {\n        $count -= 32 * divisor_sum($n >> 2);\n    }\n\n    return $count;\n}\n\nforeach my $n (1 .. 20) {\n    say \"R($n) = \", count_representations_as_four_squares($n);\n}\n\n__END__\nR(1) = 8\nR(2) = 24\nR(3) = 32\nR(4) = 24\nR(5) = 48\nR(6) = 96\nR(7) = 64\nR(8) = 24\nR(9) = 104\nR(10) = 144\nR(11) = 96\nR(12) = 96\nR(13) = 112\nR(14) = 192\nR(15) = 192\nR(16) = 24\nR(17) = 144\nR(18) = 312\nR(19) = 160\nR(20) = 144\n"
  },
  {
    "path": "Math/number_of_representations_as_sum_of_two_squares.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 23 October 2017\n# https://github.com/trizen\n\n# Counting the number of representations for a given number `n` expressed as the sum of two squares.\n\n# Formula:\n#   R(n) = 4 * Prod_{ p^k|n, p = 1 (mod 4) } (k + 1)\n\n# See also:\n#   https://oeis.org/A004018\n#   https://en.wikipedia.org/wiki/Fermat%27s_theorem_on_sums_of_two_squares\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(divisors valuation factor_exp vecsum vecprod);\n\nsub r2($n) {\n\n    my $count = 4;\n    foreach my $p (factor_exp($n)) {\n\n        my $r = $p->[0] % 4;\n\n        if ($r == 3) {\n            $p->[1] % 2 == 0 or return 0;\n        }\n\n        if ($r == 1) {\n            $count *= $p->[1] + 1;\n        }\n    }\n\n    return $count;\n}\n\nforeach my $n (1 .. 30) {\n    my $count = r2($n);\n\n    if ($count != 0) {\n        say \"R($n) = $count\";\n    }\n}\n\n__END__\nR(1) = 4\nR(2) = 4\nR(4) = 4\nR(5) = 8\nR(8) = 4\nR(9) = 4\nR(10) = 8\nR(13) = 8\nR(16) = 4\nR(17) = 8\nR(18) = 4\nR(20) = 8\nR(25) = 12\nR(26) = 8\nR(29) = 8\n"
  },
  {
    "path": "Math/number_to_digits_subquadratic_algorithm.pl",
    "content": "#!/usr/bin/perl\n\n# Subquadratic algorithm for converting a given integer into a list of digits in a given base.\n\n# Algorithm presented in the book:\n#\n#   Modern Computer Arithmetic\n#           - by Richard P. Brent and Paul Zimmermann\n#\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub FastIntegerOutput ($A, $B) {\n\n    if ($A < $B) {\n        return $A;\n    }\n\n    # Find k such that B^(2k - 2) <= A < B^(2k)\n    my $k = (logint($A, $B) >> 1) + 1;\n\n    my ($Q, $R) = divrem($A, powint($B, $k));\n    my @r = __SUB__->($R, $B);\n\n    (__SUB__->($Q, $B), (0) x ($k - scalar(@r)), @r);\n}\n\nforeach my $B (2 .. 100) {    # run some tests\n    my $N = factorial($B);    # int(rand(~0));\n\n    my @a = todigits($N, $B);\n    my @b = FastIntegerOutput($N, $B);\n\n    if (\"@a\" ne \"@b\") {\n        die \"Error for FastIntegerOutput($N, $B): (@a) != (@b)\";\n    }\n}\n\nsay join ', ', FastIntegerOutput(5040, 10);    #=> 5, 0, 4, 0\nsay join ', ', FastIntegerOutput(5040, 11);    #=> 3, 8, 7, 2\nsay join ', ', FastIntegerOutput(5040, 12);    #=> 2, 11, 0, 0\nsay join ', ', FastIntegerOutput(5040, 13);    #=> 2, 3, 10, 9\n"
  },
  {
    "path": "Math/number_to_digits_subquadratic_algorithm_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Subquadratic algorithm for converting a given integer into a list of digits in a given base.\n\n# Algorithm presented in the book:\n#\n#   Modern Computer Arithmetic\n#           - by Richard P. Brent and Paul Zimmermann\n#\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub FastIntegerOutput ($A, $B) {\n\n    $A = Math::GMPz->new(\"$A\");\n\n    # Find k such that B^(2k - 2) <= A < B^(2k)\n    my $k = (logint($A, $B) >> 1) + 1;\n\n    my $Q = Math::GMPz::Rmpz_init();\n    my $R = Math::GMPz::Rmpz_init();\n\n    sub ($A, $k) {\n\n        if (Math::GMPz::Rmpz_cmp_ui($A, $B) < 0) {\n            return Math::GMPz::Rmpz_get_ui($A);\n        }\n\n        my $t = Math::GMPz::Rmpz_init();\n        Math::GMPz::Rmpz_ui_pow_ui($t, $B, 2 * ($k - 1));   # can this be optimized away?\n\n        if (Math::GMPz::Rmpz_cmp($t, $A) > 0) {\n            --$k;\n        }\n\n        Math::GMPz::Rmpz_ui_pow_ui($t, $B, $k);\n        Math::GMPz::Rmpz_divmod($Q, $R, $A, $t);\n\n        my $w = ($k + 1) >> 1;\n        Math::GMPz::Rmpz_set($t, $Q);\n\n        my @right = __SUB__->($R, $w);\n        my @left  = __SUB__->($t, $w);\n\n        (@left, (0) x ($k - scalar(@right)), @right);\n    }->($A, $k);\n}\n\nforeach my $B (2 .. 100) {    # run some tests\n    my $N = factorial($B);    # int(rand(~0));\n\n    my @a = todigits($N, $B);\n    my @b = FastIntegerOutput($N, $B);\n\n    if (\"@a\" ne \"@b\") {\n        die \"Error for FastIntegerOutput($N, $B): (@a) != (@b)\";\n    }\n}\n\nsay join ', ', FastIntegerOutput(5040, 10);    #=> 5, 0, 4, 0\nsay join ', ', FastIntegerOutput(5040, 11);    #=> 3, 8, 7, 2\nsay join ', ', FastIntegerOutput(5040, 12);    #=> 2, 11, 0, 0\nsay join ', ', FastIntegerOutput(5040, 13);    #=> 2, 3, 10, 9\n"
  },
  {
    "path": "Math/numbers_with_pow_2_divisors.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 21 September 2016\n# Website: https://github.com/trizen\n\n# First smallest numbers with 2^n divisors.\n\n# See also:\n#    https://oeis.org/A037992\n#    https://projecteuler.net/problem=500\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(forprimes primes logint);\n\nsub first_n {\n    my ($num) = @_;\n\n    my $limit = logint($num, 2) * $num;    # overshoots a little bit\n    my @factors = @{primes($limit)};\n\n    forprimes {\n        my $t = $_;\n        while (($t**= 2) <= $limit) {\n            push @factors, $t;\n        }\n    } $num;\n\n    @factors = sort { $a <=> $b } @factors;\n    $#factors = $num - 2;\n\n    my @nums = 1;\n    my $prod = 1;\n\n    foreach my $f (@factors) {\n        $prod *= $f;\n        push @nums, $prod;\n    }\n\n    @nums;\n}\n\nsay for first_n(10)\n\n__END__\n1\n2\n6\n24\n120\n840\n7560\n83160\n1081080\n17297280\n"
  },
  {
    "path": "Math/omega_prime_divisors.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 21 March 2021\n# https://github.com/trizen\n\n# Generate all the k-omega prime divisors of n.\n\n# Definition:\n#   k-omega primes are numbers n such that omega(n) == k.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://en.wikipedia.org/wiki/Prime_omega_function\n\nuse 5.020;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub omega_prime_divisors ($n, $k) {\n\n    if ($k == 0) {\n        return (1);\n    }\n\n    my @factor_exp  = factor_exp($n);\n    my @factors     = map { $_->[0] } @factor_exp;\n    my %valuations  = map { @$_ } @factor_exp;\n    my $factors_end = $#factors;\n\n    if ($k > scalar(@factor_exp)) {\n        return;\n    }\n\n    my @list;\n\n    sub ($m, $k, $i = 0) {\n\n        my $L = rootint(divint($n, $m), $k);\n\n        foreach my $j ($i .. $factors_end) {\n\n            my $q = $factors[$j];\n\n            if (($k > 1 and $j == $factors_end) or ($q > $L)) {\n                last;\n            }\n\n            my $t = mulint($m, $q);\n\n            foreach (1 .. $valuations{$q}) {\n\n                if ($k == 1) {\n                    push @list, $t;\n                }\n                else {\n                    __SUB__->($t, $k - 1, $j + 1);\n                }\n\n                $t = mulint($t, $q);\n            }\n        }\n    }->(1, $k);\n\n    sort { $a <=> $b } @list;\n}\n\nmy $n = factorial(10);\n\nforeach my $k (0 .. prime_omega($n)) {\n    my @divisors = omega_prime_divisors($n, $k);\n    printf(\"%2d-omega prime divisors of %s: [%s]\\n\", $k, $n, join(', ', @divisors));\n}\n\n__END__\n 0-omega prime divisors of 3628800: [1]\n 1-omega prime divisors of 3628800: [2, 3, 4, 5, 7, 8, 9, 16, 25, 27, 32, 64, 81, 128, 256]\n 2-omega prime divisors of 3628800: [6, 10, 12, 14, 15, 18, 20, 21, 24, 28, 35, 36, 40, 45, 48, 50, 54, 56, 63, 72, 75, 80, 96, 100, 108, 112, 135, 144, 160, 162, 175, 189, 192, 200, 216, 224, 225, 288, 320, 324, 384, 400, 405, 432, 448, 567, 576, 640, 648, 675, 768, 800, 864, 896, 1152, 1280, 1296, 1600, 1728, 1792, 2025, 2304, 2592, 3200, 3456, 5184, 6400, 6912, 10368, 20736]\n 3-omega prime divisors of 3628800: [30, 42, 60, 70, 84, 90, 105, 120, 126, 140, 150, 168, 180, 240, 252, 270, 280, 300, 315, 336, 350, 360, 378, 450, 480, 504, 525, 540, 560, 600, 672, 700, 720, 756, 810, 900, 945, 960, 1008, 1080, 1120, 1134, 1200, 1344, 1350, 1400, 1440, 1512, 1575, 1620, 1800, 1920, 2016, 2160, 2240, 2268, 2400, 2688, 2700, 2800, 2835, 2880, 3024, 3240, 3600, 3840, 4032, 4050, 4320, 4480, 4536, 4725, 4800, 5376, 5400, 5600, 5760, 6048, 6480, 7200, 8064, 8100, 8640, 8960, 9072, 9600, 10800, 11200, 11520, 12096, 12960, 14175, 14400, 16128, 16200, 17280, 18144, 19200, 21600, 22400, 24192, 25920, 28800, 32400, 34560, 36288, 43200, 44800, 48384, 51840, 57600, 64800, 72576, 86400, 103680, 129600, 145152, 172800, 259200, 518400]\n 4-omega prime divisors of 3628800: [210, 420, 630, 840, 1050, 1260, 1680, 1890, 2100, 2520, 3150, 3360, 3780, 4200, 5040, 5670, 6300, 6720, 7560, 8400, 9450, 10080, 11340, 12600, 13440, 15120, 16800, 18900, 20160, 22680, 25200, 26880, 28350, 30240, 33600, 37800, 40320, 45360, 50400, 56700, 60480, 67200, 75600, 80640, 90720, 100800, 113400, 120960, 134400, 151200, 181440, 201600, 226800, 241920, 302400, 362880, 403200, 453600, 604800, 725760, 907200, 1209600, 1814400, 3628800]\n"
  },
  {
    "path": "Math/omega_prime_numbers_in_range.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 14 March 2021\n# https://github.com/trizen\n\n# Generate k-omega primes in range [a,b]. (not in sorted order)\n\n# Definition:\n#   k-omega primes are numbers n such that omega(n) = k.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://en.wikipedia.org/wiki/Prime_omega_function\n\n# PARI/GP code:\n#   omega_numbers(A, B, n) = A=max(A, vecprod(primes(n))); local(f); (f = (m, p, j) -> my(list=List()); forprime(q=p, sqrtnint(B\\m, j), my(v=m*q); while(v <= B, if(j==1, if(v>=A, listput(list, v)), if(v*(q+1) <= B, list=concat(list, f(v, q+1, j-1)))); v *= q)); list); vecsort(Vec(f(1, 2, n)));\n\nuse 5.020;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub omega_prime_numbers ($A, $B, $k, $callback) {\n\n    $A = vecmax($A, pn_primorial($k));\n\n    sub ($m, $p, $k) {\n\n        my $s = rootint(divint($B, $m), $k);\n\n        foreach my $q (@{primes($p, $s)}) {\n\n            my $r = next_prime($q);\n\n            for (my $v = mulint($m, $q); $v <= $B ; $v = mulint($v, $q)) {\n                if ($k == 1) {\n                    $callback->($v) if ($v >= $A);\n                }\n                elsif (mulint($v, $r) <= $B) {\n                    __SUB__->($v, $r, $k - 1);\n                }\n            }\n        }\n    }->(1, 2, $k);\n}\n\n# Generate 5-omega primes in the range [3000, 10000]\n\nmy $k    = 5;\nmy $from = 3000;\nmy $upto = 10000;\n\nmy @arr;\nomega_prime_numbers($from, $upto, $k, sub ($n) { push @arr, $n });\n\nmy @test = grep { prime_omega($_) == $k } $from .. $upto;    # just for testing\njoin(' ', sort { $a <=> $b } @arr) eq join(' ', @test) or die \"Error: not equal!\";\n\nsay join(', ', @arr);\n\n# Run some tests\n\nforeach my $k (1 .. 6) {\n\n    my $from = pn_primorial($k) + int(rand(1e4));\n    my $upto = $from + int(rand(1e5));\n\n    say \"Testing: $k with $from .. $upto\";\n\n    my @arr;\n    omega_prime_numbers($from, $upto, $k, sub ($n) { push @arr, $n });\n\n    my @test = grep { prime_omega($_) == $k } $from .. $upto;\n    join(' ', sort { $a <=> $b } @arr) eq join(' ', @test) or die \"Error: not equal!\";\n}\n"
  },
  {
    "path": "Math/omega_prime_numbers_in_range_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 14 March 2021\n# Edit: 04 April 2024\n# https://github.com/trizen\n\n# Generate all the k-omega primes in range [A,B].\n\n# Definition:\n#   k-omega primes are numbers n such that omega(n) = k.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://en.wikipedia.org/wiki/Prime_omega_function\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory qw(:all);\n\nsub omega_prime_numbers ($A, $B, $k) {\n\n    $A = vecmax($A, pn_primorial($k));\n    $A = Math::GMPz->new(\"$A\");\n    $B = Math::GMPz->new(\"$B\");\n\n    my $u = Math::GMPz::Rmpz_init();\n\n    my @values = sub ($m, $lo, $j) {\n\n        Math::GMPz::Rmpz_tdiv_q($u, $B, $m);\n        Math::GMPz::Rmpz_root($u, $u, $j);\n\n        my $hi = Math::GMPz::Rmpz_get_ui($u);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        my @lst;\n        my $v = Math::GMPz::Rmpz_init();\n\n        foreach my $q (@{primes($lo, $hi)}) {\n\n            Math::GMPz::Rmpz_mul_ui($v, $m, $q);\n\n            while (Math::GMPz::Rmpz_cmp($v, $B) <= 0) {\n                if ($j == 1) {\n                    if (Math::GMPz::Rmpz_cmp($v, $A) >= 0) {\n                        push @lst, Math::GMPz::Rmpz_init_set($v);\n                    }\n                }\n                else {\n                    push @lst, __SUB__->($v, $q + 1, $j - 1);\n                }\n                Math::GMPz::Rmpz_mul_ui($v, $v, $q);\n            }\n        }\n\n        return @lst;\n      }\n      ->(Math::GMPz->new(1), 2, $k);\n\n    sort { Math::GMPz::Rmpz_cmp($a, $b) } @values;\n}\n\n# Generate 5-omega primes in the range [3000, 10000]\n\nmy $k    = 5;\nmy $from = 3000;\nmy $upto = 10000;\n\nmy @arr  = omega_prime_numbers($from, $upto, $k);\nmy @test = grep { prime_omega($_) == $k } $from .. $upto;    # just for testing\n\njoin(' ', @arr) eq join(' ', @test) or die \"Error: not equal!\";\n\nsay join(', ', @arr);\n\n# Run some tests\n\nforeach my $k (1 .. 6) {\n\n    my $from = pn_primorial($k) + int(rand(1e4));\n    my $upto = $from + int(rand(1e5));\n\n    say \"Testing: $k with $from .. $upto\";\n\n    my @arr  = omega_prime_numbers($from, $upto, $k);\n    my @test = grep { prime_omega($_) == $k } $from .. $upto;\n    join(' ', @arr) eq join(' ', @test) or die \"Error: not equal!\";\n}\n"
  },
  {
    "path": "Math/omega_prime_numbers_in_range_simple.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 14 March 2021\n# Edit: 25 March 2025\n# https://github.com/trizen\n\n# Generate k-omega primes in range [a,b]. (not in sorted order)\n\n# Definition:\n#   k-omega primes are numbers n such that omega(n) = k.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://en.wikipedia.org/wiki/Prime_omega_function\n\nuse 5.020;\nuse integer;\nuse ntheory      qw(:all);\nuse experimental qw(signatures);\n\nsub omega_prime_numbers ($A, $B, $k, $callback) {\n\n    $A = vecmax($A, pn_primorial($k));\n\n    sub ($m, $p, $k) {\n\n        my $s = rootint($B / $m, $k);\n\n        foreach my $q (@{primes($p, $s)}) {\n\n            my $r = next_prime($q);\n\n            for (my $v = $m * $q ; $v <= $B ; $v *= $q) {\n                if ($k == 1) {\n                    $callback->($v) if ($v >= $A);\n                }\n                elsif ($v * $r <= $B) {\n                    __SUB__->($v, $r, $k - 1);\n                }\n            }\n        }\n    }->(1, 2, $k);\n}\n\n# Generate 5-omega primes in the range [3000, 10000]\n\nmy $k    = 5;\nmy $from = 3000;\nmy $upto = 10000;\n\nmy @arr;\nomega_prime_numbers($from, $upto, $k, sub ($n) { push @arr, $n });\n\nmy @test = grep { prime_omega($_) == $k } $from .. $upto;    # just for testing\njoin(' ', sort { $a <=> $b } @arr) eq join(' ', @test) or die \"Error: not equal!\";\n\nsay join(', ', @arr);\n\n# Run some tests\n\nforeach my $k (1 .. 6) {\n\n    my $from = pn_primorial($k) + int(rand(1e4));\n    my $upto = $from + int(rand(1e5));\n\n    say \"Testing: $k with $from .. $upto\";\n\n    my @arr;\n    omega_prime_numbers($from, $upto, $k, sub ($n) { push @arr, $n });\n\n    my @test = grep { prime_omega($_) == $k } $from .. $upto;\n    join(' ', sort { $a <=> $b } @arr) eq join(' ', @test) or die \"Error: not equal!\";\n}\n"
  },
  {
    "path": "Math/order_factorization_method.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 02 August 2020\n# Edit: 07 January 2021\n# https://github.com/trizen\n\n# A new factorization method for numbers that have all prime factors close to each other.\n\n# Inpsired by Fermat's Little Theorem (FLT).\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse Math::GMPz;\n\nsub FLT_find_factor ($n, $base = 2, $reps = 1e5) {\n\n    $n = Math::GMPz->new(\"$n\");\n\n    state $z = Math::GMPz::Rmpz_init_nobless();\n    state $t = Math::GMPz::Rmpz_init_nobless();\n\n    my $g = Math::GMPz::Rmpz_init();\n\n    Math::GMPz::Rmpz_set_ui($t, $base);\n    Math::GMPz::Rmpz_set_ui($z, $base);\n\n    Math::GMPz::Rmpz_powm($z, $z, $n, $n);\n\n    # Cannot factor Fermat pseudoprimes\n    if (Math::GMPz::Rmpz_cmp_ui($z, $base) == 0) {\n        return undef;\n    }\n\n    my $multiplier = $base * $base;\n\n    for (my $k = 1 ; $k <= $reps ; ++$k) {\n\n        Math::GMPz::Rmpz_mul_ui($t, $t, $multiplier);\n        Math::GMPz::Rmpz_mod($t, $t, $n) if ($k % 10 == 0);\n        Math::GMPz::Rmpz_sub($g, $z, $t);\n        Math::GMPz::Rmpz_gcd($g, $g, $n);\n\n        if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {\n            return undef if (Math::GMPz::Rmpz_cmp($g, $n) == 0);\n            return $g;\n        }\n    }\n\n    return undef;\n}\n\nsay FLT_find_factor(\"1759590140239532167230871849749630652332178307219845847129\");    #=> 12072684186515582507\nsay FLT_find_factor(\"28168370236334094367936640078057043313881469151722840306493\");   #=> 30426633744568826749\n\nsay FLT_find_factor(\"97967651586822913179896725042136997967830602144506842054615710025444417607092711829309187\");     #=> 86762184769343281845479348731\nsay FLT_find_factor(\"1129151505892449502375764445221583755878554451745780900429977\", 3);                              #=> 867621847693432818454793487397\n"
  },
  {
    "path": "Math/palindrome_iteration.pl",
    "content": "#!/usr/bin/perl\n\n# A nice algorithm, due to David A. Corneth (Jun 06 2014), for interating over palindromic numbers in base 10.\n\n# See also:\n#   https://oeis.org/A002113\n#   https://en.wikipedia.org/wiki/Palindromic_number\n\n# This program illustrates how to compute terms of:\n#   https://oeis.org/A076886\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nmy $n = 1;\nmy @d = split(//, $n);\n\nmy %table;\n\nwhile (1) {\n\n    my $r = prime_bigomega($n);\n\n    if (not exists $table{$r}) {\n        say \"a($r) = $n\";\n        $table{$r} = 1;\n    }\n\n    my $l = $#d;\n    my $i = ((scalar(@d) + 1) >> 1) - 1;\n\n    while ($i >= 0 and $d[$i] == 9) {\n        $d[$i] = 0;\n        $d[$l - $i] = 0;\n        $i--;\n    }\n\n    if ($i >= 0) {\n        $d[$i]++;\n        $d[$l - $i] = $d[$i];\n    }\n    else {\n        @d = (0) x (scalar(@d) + 1);\n        $d[0]  = 1;\n        $d[-1] = 1;\n    }\n\n    $n = join('', @d);\n}\n"
  },
  {
    "path": "Math/partial_sums_of_dedekind_psi_function.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 22 November 2018\n# https://github.com/trizen\n\n# A new algorithm for computing the partial-sums of the Dedekind psi function `ψ_m(k)`, for `1 <= k <= n`:\n#\n#   Sum_{k=1..n} ψ_m(k)\n#\n# for any fixed integer m >= 1.\n\n# Based on the formula:\n#   Sum_{k=1..n} ψ_m(k) = Sum_{k=1..n} moebius(k)^2 * F(m, floor(n/k))\n#\n# where F(n,x) is Faulhaber's formula for `Sum_{k=1..x} k^n`, defined in terms of Bernoulli polynomials as:\n#   F(n, x) = (Bernoulli(n+1, x+1) - Bernoulli(n+1, 1)) / (n+1)\n\n# Example for a(n) = Sum_{k=1..n} ψ_2(k):\n#   a(10^1)  = 462\n#   a(10^2)  = 400576\n#   a(10^3)  = 394504950\n#   a(10^4)  = 393921912410\n#   a(10^5)  = 393861539651230\n#   a(10^6)  = 393855661025817568\n#   a(10^7)  = 393855049001462029696\n#   a(10^8)  = 393854989687473892017612\n#   a(10^9)  = 393854983651633712634417940\n#   a(10^10) = 393854983070527507612754907046\n\n# For m=1..3, we have the following asymptotic formulas:\n#   Sum_{k=1..n} ψ_1(k) ~ n^2 * zeta(2) / (2*zeta(4))\n#   Sum_{k=1..n} ψ_2(k) ~ n^3 * zeta(3) / (3*zeta(6))\n#   Sum_{k=1..n} ψ_3(k) ~ n^4 * zeta(4) / (4*zeta(8))\n\n# In general, for m>=1, we have:\n#   Sum_{k=1..n} ψ_m(k) ~ n^(m+1) * zeta(m+1) / ((m+1) * zeta(2*(m+1)))\n\n# See also:\n#   https://oeis.org/A173290\n#   https://en.wikipedia.org/wiki/M%C3%B6bius_function\n#   https://en.wikipedia.org/wiki/Dedekind_psi_function\n#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(ipow faulhaber_sum);\nuse ntheory qw(jordan_totient moebius vecsum sqrtint forsquarefree is_square_free);\n\nsub squarefree_count {\n    my ($n) = @_;\n\n    my $k     = 0;\n    my $count = 0;\n\n    foreach my $m (moebius(1, sqrtint($n))) {\n        ++$k; $count += $m * int($n / $k / $k);\n    }\n\n    return $count;\n}\n\nsub dedekind_psi_partial_sum ($n, $m) {     # O(sqrt(n)) complexity\n\n    my $total = 0;\n\n    my $s = sqrtint($n);\n    my $u = int($n / ($s + 1));\n\n    my $prev = squarefree_count($n);\n\n    for my $k (1 .. $s) {\n        my $curr = squarefree_count(int($n / ($k + 1)));\n        $total += ($prev - $curr) * faulhaber_sum($k, $m);\n        $prev = $curr;\n    }\n\n    forsquarefree {\n        $total += faulhaber_sum(int($n / $_), $m);\n    } $u;\n\n    return $total;\n}\n\nsub dedekind_psi_partial_sum_2 ($n, $m) {     # O(sqrt(n)) complexity\n\n    my $total = 0;\n    my $s = sqrtint($n);\n\n    for my $k (1 .. $s) {\n        $total += ipow($k, $m) * squarefree_count(int($n/$k));\n        $total += faulhaber_sum(int($n/$k), $m) if is_square_free($k);\n    }\n\n    $total -= squarefree_count($s) * faulhaber_sum($s, $m);\n\n    return $total;\n}\n\nsub dedekind_psi_partial_sum_test ($n, $m) {    # just for testing\n    vecsum(map { jordan_totient(2*$m, $_) / jordan_totient($m, $_) } 1 .. $n);\n}\n\nfor my $m (1 .. 10) {\n\n    my $n = int rand 1000;\n\n    my $t1 = dedekind_psi_partial_sum($n, $m);\n    my $t2 = dedekind_psi_partial_sum_2($n, $m);\n    my $t3 = dedekind_psi_partial_sum_test($n, $m);\n\n    die \"error: $t1 != $t2\" if ($t1 != $t2);\n    die \"error: $t1 != $t3\" if ($t1 != $t3);\n\n    say \"Sum_{k=1..$n} psi_$m(k) = $t1\";\n}\n\n__END__\nSum_{k=1..626} psi_1(k) = 298020\nSum_{k=1..203} psi_2(k) = 3314412\nSum_{k=1..527} psi_3(k) = 20858324486\nSum_{k=1..912} psi_4(k) = 131086192304600\nSum_{k=1..221} psi_5(k) = 20014030184914\nSum_{k=1..980} psi_6(k) = 125495875567427222916\nSum_{k=1..892} psi_7(k) = 50529225624273249380976\nSum_{k=1..831} psi_8(k) = 21153451972416324344508126\nSum_{k=1..384} psi_9(k) = 7069511971715257063270976\nSum_{k=1..434} psi_10(k) = 9477667039001209551910807864\n"
  },
  {
    "path": "Math/partial_sums_of_euler_totient_function.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 20 November 2018\n# https://github.com/trizen\n\n# A new algorithm for computing the partial-sums of `ϕ(k)`, for `1 <= k <= n`:\n#\n#   Sum_{k=1..n} phi(k)\n#\n# where phi(k) is the Euler totient function.\n\n# Based on the formula:\n#   Sum_{k=1..n} phi(k) = (1/2)*Sum_{k=1..n} moebius(k) * floor(n/k) * floor(1+n/k)\n\n# Example:\n#   a(10^1) = 32\n#   a(10^2) = 3044\n#   a(10^3) = 304192\n#   a(10^4) = 30397486\n#   a(10^5) = 3039650754\n#   a(10^6) = 303963552392\n#   a(10^7) = 30396356427242\n#   a(10^8) = 3039635516365908\n#   a(10^9) = 303963551173008414\n\n# This algorithm can be improved.\n\n# See also:\n#   https://oeis.org/A002088\n#   https://oeis.org/A064018\n#   https://en.wikipedia.org/wiki/Mertens_function\n#   https://en.wikipedia.org/wiki/M%C3%B6bius_function\n#   https://en.wikipedia.org/wiki/Euler%27s_totient_function\n#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::GMPz qw();\nuse experimental qw(signatures);\nuse ntheory qw(euler_phi moebius mertens vecsum sqrtint forsquarefree);\n\nsub euler_totient_partial_sum ($n) {\n\n    my $total = Math::GMPz->new(0);\n\n    my $s = sqrtint($n);\n    my $u = int($n / ($s + 1));\n\n    my $prev = mertens($n);\n\n    for my $k (1 .. $s) {\n        my $curr = mertens(int($n / ($k + 1)));\n        $total += ($prev - $curr) * $k * ($k + 1);\n        $prev = $curr;\n    }\n\n    forsquarefree {\n        my $t = int($n / $_);\n        $total += moebius($_) * $t * ($t + 1);\n    } $u;\n\n    return $total / 2;\n}\n\nsub euler_totient_partial_sum_test ($n) {    # just for testing\n    vecsum(map { euler_phi($_) } 1 .. $n);\n}\n\nfor my $m (0 .. 10) {\n\n    my $n = int rand 10000;\n\n    my $t1 = euler_totient_partial_sum($n);\n    my $t2 = euler_totient_partial_sum_test($n);\n\n    die \"error: $t1 != $t2\" if ($t1 != $t2);\n\n    say \"Sum_{k=1..$n} phi(k) = $t1\";\n}\n\n__END__\nSum_{k=1..9321} phi(k) = 26411174\nSum_{k=1..2266} phi(k) = 1560824\nSum_{k=1..1049} phi(k) = 335018\nSum_{k=1..2571} phi(k) = 2009942\nSum_{k=1..3858} phi(k) = 4524786\nSum_{k=1..7348} phi(k) = 16412608\nSum_{k=1..7177} phi(k) = 15659862\nSum_{k=1..1247} phi(k) = 473174\nSum_{k=1..9787} phi(k) = 29119732\nSum_{k=1..4790} phi(k) = 6975570\nSum_{k=1..2453} phi(k) = 1830240\n"
  },
  {
    "path": "Math/partial_sums_of_euler_totient_function_fast.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 04 February 2019\n# https://github.com/trizen\n\n# A sublinear algorithm for computing the partial sums of the Euler totient function.\n\n# The partial sums of the Euler totient function is defined as:\n#\n#   a(n) = Sum_{k=1..n} phi(k)\n#\n# where phi(k) is the Euler totient function.\n\n# Recursive formula:\n#   a(n) = n*(n+1)/2 - Sum_{k=2..sqrt(n)} a(floor(n/k)) - Sum_{k=1..floor(n/sqrt(n))-1} a(k) * (floor(n/k) - floor(n/(k+1)))\n\n# Example:\n#   a(10^1) = 32\n#   a(10^2) = 3044\n#   a(10^3) = 304192\n#   a(10^4) = 30397486\n#   a(10^5) = 3039650754\n#   a(10^6) = 303963552392\n#   a(10^7) = 30396356427242\n#   a(10^8) = 3039635516365908\n#   a(10^9) = 303963551173008414\n\n# OEIS sequences:\n#   https://oeis.org/A002088 -- Sum of totient function: a(n) = Sum_{k=1..n} phi(k).\n#   https://oeis.org/A064018 -- Sum of the Euler totients phi for 10^n.\n#   https://oeis.org/A272718 -- Partial sums of gcd-sum sequence A018804.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Dirichlet_hyperbola_method\n#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(euler_phi sqrtint rootint);\n\nsub partial_sums_of_euler_totient($n) {\n    my $s = sqrtint($n);\n\n    my @euler_sum_lookup = (0);\n\n    my $lookup_size = 2 * rootint($n, 3)**2;\n    my @euler_phi   = euler_phi(0, $lookup_size);\n\n    foreach my $i (1 .. $lookup_size) {\n        $euler_sum_lookup[$i] = $euler_sum_lookup[$i - 1] + $euler_phi[$i];\n    }\n\n    my %seen;\n\n    sub ($n) {\n\n        if ($n <= $lookup_size) {\n            return $euler_sum_lookup[$n];\n        }\n\n        if (exists $seen{$n}) {\n            return $seen{$n};\n        }\n\n        my $s = sqrtint($n);\n        my $T = ($n * ($n + 1)) >> 1;\n\n        foreach my $k (2 .. int($n / ($s + 1))) {\n            $T -= __SUB__->(int($n / $k));\n        }\n\n        foreach my $k (1 .. $s) {\n            $T -= (int($n / $k) - int($n / ($k + 1))) * $euler_sum_lookup[$k];\n        }\n\n        $seen{$n} = $T;\n\n    }->($n);\n}\n\nforeach my $n (1 .. 8) {    # takes less than 1 second\n    say \"a(10^$n) = \", partial_sums_of_euler_totient(10**$n);\n}\n"
  },
  {
    "path": "Math/partial_sums_of_euler_totient_function_fast_2.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 05 April 2022\n# https://github.com/trizen\n\n# A sublinear algorithm for computing the partial sums of the Euler totient function.\n\n# The partial sums of the Euler totient function is defined as:\n#\n#   a(n,m) = Sum_{k=1..n} phi(k)\n#\n# where phi(k) is the Euler totient function.\n\n# Example:\n#   a(10^1)  = 32\n#   a(10^2)  = 3044\n#   a(10^3)  = 304192\n#   a(10^4)  = 30397486\n#   a(10^5)  = 3039650754\n#   a(10^6)  = 303963552392\n#   a(10^7)  = 30396356427242\n#   a(10^8)  = 3039635516365908\n#   a(10^9)  = 303963551173008414\n#   a(10^10) = 30396355092886216366\n\n# General asymptotic formula:\n#\n#   Sum_{k=1..n} k^m * phi(k)  ~  F_{m+1}(n) / zeta(2).\n#\n# where F_m(n) are the Faulhaber polynomials.\n\n# OEIS sequences:\n#   https://oeis.org/A011755 -- Sum_{k=1..n} k*phi(k).\n#   https://oeis.org/A002088 -- Sum of totient function: a(n) = Sum_{k=1..n} phi(k).\n#   https://oeis.org/A064018 -- Sum of the Euler totients phi for 10^n.\n#   https://oeis.org/A272718 -- Partial sums of gcd-sum sequence A018804.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Faulhaber's_formula\n#   https://en.wikipedia.org/wiki/Dirichlet_hyperbola_method\n#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub triangular ($n) {\n    divint(mulint($n, $n + 1), 2);\n}\n\nsub partial_sums_of_euler_totient ($n) {\n    my $s = sqrtint($n);\n\n    my @euler_sum_lookup = (0);\n\n    my $lookup_size = int(2 * rootint($n, 3)**2);\n    my @euler_phi   = euler_phi(0, $lookup_size);\n\n    foreach my $i (1 .. $lookup_size) {\n        $euler_sum_lookup[$i] = addint($euler_sum_lookup[$i - 1], $euler_phi[$i]);\n    }\n\n    my %seen;\n\n    sub ($n) {\n\n        if ($n <= $lookup_size) {\n            return $euler_sum_lookup[$n];\n        }\n\n        if (exists $seen{$n}) {\n            return $seen{$n};\n        }\n\n        my $s = sqrtint($n);\n        my $T = triangular($n);\n\n        foreach my $k (2 .. divint($n, $s + 1)) {\n            $T = subint($T, __SUB__->(divint($n, $k)));\n        }\n\n        my $prev = $n;\n\n        foreach my $k (1 .. $s) {\n            my $curr = divint($n, $k + 1);\n            $T    = subint($T, mulint(subint($prev, $curr), $euler_sum_lookup[$k]));\n            $prev = $curr;\n        }\n\n        $seen{$n} = $T;\n\n    }->($n);\n}\n\nforeach my $n (1 .. 8) {    # takes less than 1 second\n    say \"a(10^$n) = \", partial_sums_of_euler_totient(powint(10, $n));\n}\n"
  },
  {
    "path": "Math/partial_sums_of_euler_totient_function_times_k.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 05 April 2022\n# https://github.com/trizen\n\n# A sublinear algorithm for computing the partial sums of the Euler totient function times k.\n\n# The partial sums of the Euler totient function is defined as:\n#\n#   a(n,m) = Sum_{k=1..n} k * phi(k)\n#\n# where phi(k) is the Euler totient function.\n\n# Example:\n#    a(10^1)  = 217\n#    a(10^2)  = 203085\n#    a(10^3)  = 202870719\n#    a(10^4)  = 202653667159\n#    a(10^5)  = 202643891472849\n#    a(10^6)  = 202642368741515819\n#    a(10^7)  = 202642380629476099463\n#    a(10^8)  = 202642367994273571457613\n#    a(10^9)  = 202642367530671221417109931\n#    a(10^10) = 202642367286524384080814204093\n\n# General asymptotic formula:\n#\n#   Sum_{k=1..n} k^m * phi(k)  ~  F_(m+1)(n) / zeta(2).\n#\n# where F_m(n) are the Faulhaber polynomials.\n\n# OEIS sequences:\n#   https://oeis.org/A011755 -- Sum_{k=1..n} k*phi(k).\n#   https://oeis.org/A002088 -- Sum of totient function: a(n) = Sum_{k=1..n} phi(k).\n#   https://oeis.org/A064018 -- Sum of the Euler totients phi for 10^n.\n#   https://oeis.org/A272718 -- Partial sums of gcd-sum sequence A018804.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Faulhaber's_formula\n#   https://en.wikipedia.org/wiki/Dirichlet_hyperbola_method\n#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(:all);\n\nsub triangular ($n) {\n    divint(mulint($n, $n + 1), 2);\n}\n\nsub square_pyramidal ($n) {\n    divint(vecprod($n, $n + 1, mulint(2, $n) + 1), 6);\n}\n\nsub partial_sums_of_euler_totient ($n) {\n    my $s = sqrtint($n);\n\n    my @euler_sum_lookup = (0);\n\n    my $lookup_size = int(2 * rootint($n, 3)**2);\n    my @euler_phi   = euler_phi(0, $lookup_size);\n\n    foreach my $i (1 .. $lookup_size) {\n        $euler_sum_lookup[$i] = addint($euler_sum_lookup[$i - 1], mulint($i, $euler_phi[$i]));\n    }\n\n    my %seen;\n\n    sub ($n) {\n\n        if ($n <= $lookup_size) {\n            return $euler_sum_lookup[$n];\n        }\n\n        if (exists $seen{$n}) {\n            return $seen{$n};\n        }\n\n        my $s = sqrtint($n);\n        my $T = square_pyramidal($n);\n\n        foreach my $k (2 .. divint($n, $s + 1)) {\n            $T = subint($T, mulint($k, __SUB__->(divint($n, $k))));\n        }\n\n        my $prev = triangular($n);\n\n        foreach my $k (1 .. $s) {\n            my $curr = triangular(divint($n, $k + 1));\n            $T    = subint($T, mulint(subint($prev, $curr), $euler_sum_lookup[$k]));\n            $prev = $curr;\n        }\n\n        $seen{$n} = $T;\n\n    }->($n);\n}\n\nforeach my $n (1 .. 8) {    # takes ~5 seconds\n    say \"a(10^$n) = \", partial_sums_of_euler_totient(powint(10, $n));\n}\n"
  },
  {
    "path": "Math/partial_sums_of_euler_totient_function_times_k_to_the_m.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 07 February 2019\n# https://github.com/trizen\n\n# A sublinear algorithm for computing the partial sums of the Euler totient function times k^m.\n\n# The partial sums of the Euler totient function is defined as:\n#\n#   a(n,m) = Sum_{k=1..n} k^m * phi(k)\n#\n# where phi(k) is the Euler totient function.\n\n# Example:\n#    a(10^1, 1) = 217\n#    a(10^2, 1) = 203085\n#    a(10^3, 1) = 202870719\n#    a(10^4, 1) = 202653667159\n#    a(10^5, 1) = 202643891472849\n#    a(10^6, 1) = 202642368741515819\n#    a(10^7, 1) = 202642380629476099463\n#    a(10^8, 1) = 202642367994273571457613\n#    a(10^9, 1) = 202642367530671221417109931\n\n# General asymptotic formula:\n#\n#   Sum_{k=1..n} k^m * phi(k)  ~  F_(m+1)(n) / zeta(2).\n#\n# where F_m(n) are the Faulhaber polynomials.\n\n# OEIS sequences:\n#   https://oeis.org/A011755 -- Sum_{k=1..n} k*phi(k).\n#   https://oeis.org/A002088 -- Sum of totient function: a(n) = Sum_{k=1..n} phi(k).\n#   https://oeis.org/A064018 -- Sum of the Euler totients phi for 10^n.\n#   https://oeis.org/A272718 -- Partial sums of gcd-sum sequence A018804.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Faulhaber's_formula\n#   https://en.wikipedia.org/wiki/Dirichlet_hyperbola_method\n#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(faulhaber_sum ipow);\nuse ntheory qw(euler_phi sqrtint rootint);\n\nsub partial_sums_of_euler_totient ($n, $m) {\n    my $s = sqrtint($n);\n\n    my @euler_sum_lookup = (0);\n\n    my $lookup_size = 2 * rootint($n, 3)**2;\n    my @euler_phi   = euler_phi(0, $lookup_size);\n\n    foreach my $i (1 .. $lookup_size) {\n        $euler_sum_lookup[$i] = $euler_sum_lookup[$i - 1] + ipow($i, $m) * $euler_phi[$i];\n    }\n\n    my %seen;\n\n    sub ($n) {\n\n        if ($n <= $lookup_size) {\n            return $euler_sum_lookup[$n];\n        }\n\n        if (exists $seen{$n}) {\n            return $seen{$n};\n        }\n\n        my $s = sqrtint($n);\n        my $T = faulhaber_sum($n, $m + 1);\n\n        foreach my $k (2 .. int($n / ($s + 1))) {\n            $T -= ipow($k, $m) * __SUB__->(int($n / $k));\n        }\n\n        foreach my $k (1 .. $s) {\n            $T -= (faulhaber_sum(int($n / $k), $m) - faulhaber_sum(int($n / ($k + 1)), $m)) * $euler_sum_lookup[$k];\n        }\n\n        $seen{$n} = $T;\n\n    }->($n);\n}\n\nforeach my $n (1 .. 7) {    # takes ~2.8 seconds\n    say \"a(10^$n, 1) = \", partial_sums_of_euler_totient(10**$n, 1);\n}\n"
  },
  {
    "path": "Math/partial_sums_of_exponential_prime_omega_functions.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 16 March 2021\n# https://github.com/trizen\n\n# Compute partial sums of the following three functions in sublinear time:\n#   S1(n) = Sum_{k=1..n} v^bigomega(k)\n#   S2(n) = Sum_{k=1..n} v^omega(k)\n#   S3(n) = Sum_{k=1..n} v^omega(k) * mu(k)^2\n\nuse 5.036;\nuse ntheory qw(:all);\n\nsub squarefree_almost_prime_count ($k, $n) {\n\n    if ($k == 0) {\n        return (($n <= 0) ? 0 : 1);\n    }\n\n    if ($k == 1) {\n        return prime_count($n);\n    }\n\n    my $count = 0;\n\n    sub ($m, $p, $k, $j = 1) {\n\n        my $s = rootint(divint($n, $m), $k);\n\n        if ($k == 2) {\n\n            forprimes {\n                $count += prime_count(divint($n, mulint($m, $_))) - $j++;\n            } $p, $s;\n\n            return;\n        }\n\n        for (; $p <= $s ; ++$j) {\n            my $r = next_prime($p);\n            __SUB__->(mulint($m, $p), $r, $k - 1, $j + 1);\n            $p = $r;\n        }\n    }->(1, 2, $k);\n\n    return $count;\n}\n\nsub S1 ($n, $v = 2) {    # Sum_{k=1..n} v^bigomega(k)\n    vecsum(map { mulint(powint($v, $_), almost_prime_count($_, $n)) } 0 .. logint($n, 2));\n}\n\nsub S2 ($n, $v = 2) {    # Sum_{k=1..n} v^omega(k)\n    vecsum(map { mulint(powint($v, $_), omega_prime_count($_, $n)) } 0 .. logint($n, 2));\n}\n\nsub S3 ($n, $v = 2) {    # Sum_{k=1..n} v^omega(k) * mu(k)^2\n    vecsum(map { mulint(powint($v, $_), squarefree_almost_prime_count($_, $n)) } 0 .. logint($n, 2));\n}\n\nsay join ', ', map { S1($_) } 1 .. 20;  #=> A069205: [1, 3, 5, 9, 11, 15, 17, 25, 29, 33, 35, 43, 45, 49, 53, 69, 71, 79, 81]\nsay join ', ', map { S2($_) } 1 .. 20;  #=> A064608: [1, 3, 5, 7, 9, 13, 15, 17, 19, 23, 25, 29, 31, 35, 39, 41, 43, 47, 49]\nsay join ', ', map { S3($_) } 1 .. 20;  #=> A069201: [1, 3, 5, 5, 7, 11, 13, 13, 13, 17, 19, 19, 21, 25, 29, 29, 31, 31, 33]\n\nsay '';\n\nsay join ', ', map { S1($_, -1) } 1 .. 20;  #=> A002819: [1, 0, -1, 0, -1, 0, -1, -2, -1, 0, -1, -2, -3, -2, -1, 0, -1, -2, -3, -4]\nsay join ', ', map { S2($_, -1) } 1 .. 20;  #=> A174863: [1, 0, -1, -2, -3, -2, -3, -4, -5, -4, -5, -4, -5, -4, -3, -4, -5, -4, -5, -4]\nsay join ', ', map { S3($_, -1) } 1 .. 20;  #=> A002321: [1, 0, -1, -1, -2, -1, -2, -2, -2, -1, -2, -2, -3, -2, -1, -1, -2, -2, -3, -3]\n\n__END__\n\n# A069205(n) = Sum_{k=1..n} 2^bigomega(k)\n\nA069205(10^1)  = 33\nA069205(10^2)  = 811\nA069205(10^3)  = 15301\nA069205(10^4)  = 260615\nA069205(10^5)  = 3942969\nA069205(10^6)  = 55282297\nA069205(10^7)  = 746263855\nA069205(10^8)  = 9613563919\nA069205(10^9)  = 120954854741\nA069205(10^10) = 1491898574939\nA069205(10^11) = 17944730372827\nA069205(10^12) = 212986333467973\nA069205(10^13) = 2498962573520227\nA069205(10^14) = 28874142998632109\n\n# A002819(n) = Sum_{k=1..n} (-1)^bigomega(k)\n# See also: A090410\n\nA002819(10^1) = 0\nA002819(10^2) = -2\nA002819(10^3) = -14\nA002819(10^4) = -94\nA002819(10^5) = -288\nA002819(10^6) = -530\nA002819(10^7) = -842\nA002819(10^8) = -3884\nA002819(10^9) = -25216\nA002819(10^10) = -116026\nA002819(10^11) = -342224\nA002819(10^12) = -522626\nA002819(10^13) = -966578\nA002819(10^14) = -7424752\n\n# A064608(n) = Sum_{k=1..n} 2^omega(k)\n# See also: A180361\n\nA064608(10^1)  = 23\nA064608(10^2)  = 359\nA064608(10^3)  = 4987\nA064608(10^4)  = 63869\nA064608(10^5)  = 778581\nA064608(10^6)  = 9185685\nA064608(10^7)  = 105854997\nA064608(10^8)  = 1198530315\nA064608(10^9)  = 13385107495\nA064608(10^10) = 147849112851\nA064608(10^11) = 1618471517571\nA064608(10^12) = 17584519050293\n\n# A174863(n) = Sum_{k=1..n} (-1)^omega(k)\n\nA174863(10^1)  = -4\nA174863(10^2)  = 14\nA174863(10^3)  = 64\nA174863(10^4)  = -16\nA174863(10^5)  = -720\nA174863(10^6)  = -1908\nA174863(10^7)  = -1650\nA174863(10^8)  = 10734\nA174863(10^9)  = 53740\nA174863(10^10) = 108654\nA174863(10^11) = 195702\nA174863(10^12) = 27158\n\n# A069201(n) = Sum_{k=1..n} mu(k)^2 * 2^omega(k)\n\nA069201(10^1)  = 17\nA069201(10^2)  = 211\nA069201(10^3)  = 2825\nA069201(10^4)  = 34891\nA069201(10^5)  = 414813\nA069201(10^6)  = 4808081\nA069201(10^7)  = 54684335\nA069201(10^8)  = 612868643\nA069201(10^9)  = 6788951097\nA069201(10^10) = 74492096539\nA069201(10^11) = 810947010335\nA069201(10^12) = 8769730440341\n\n# A002321(n) = Sum_{k=1..n} (-1)^omega(k) * mu(k)^2 = Sum_{k=1..n} mu(k)\n# See also: A084237\n\nA002321(10^1) = -1\nA002321(10^2) = 1\nA002321(10^3) = 2\nA002321(10^4) = -23\nA002321(10^5) = -48\nA002321(10^6) = 212\nA002321(10^7) = 1037\nA002321(10^8) = 1928\nA002321(10^9) = -222\nA002321(10^10) = -33722\nA002321(10^11) = -87856\nA002321(10^12) = 62366\n\n# A013928(n) = Sum_{k=1..n} mu(k)^2\n# See also: A071172\n\nA013928(10^1)  = 7\nA013928(10^2)  = 61\nA013928(10^3)  = 608\nA013928(10^4)  = 6083\nA013928(10^5)  = 60794\nA013928(10^6)  = 607926\nA013928(10^7)  = 6079291\nA013928(10^8)  = 60792694\nA013928(10^9)  = 607927124\nA013928(10^10) = 6079270942\nA013928(10^11) = 60792710280\nA013928(10^12) = 607927102274\n"
  },
  {
    "path": "Math/partial_sums_of_gcd-sum_function.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 20 November 2018\n# https://github.com/trizen\n\n# A new algorithm for computing the partial-sums of the gcd-sum function `Sum_{d|k} d*ϕ(k/d)`, for `1 <= k <= n`:\n#\n#   a(n) = Sum_{k=1..n} Sum_{d|k} d*phi(k/d)\n#\n# where phi(k) is the Euler totient function.\n\n# Also equivalent with:\n#   a(n) = Sum_{j=1..n} Sum_{i=1..j} gcd(i, j)\n\n# Based on the formula:\n#   a(n) = (1/2)*Sum_{k=1..n} phi(k) * floor(n/k) * floor(1+n/k)\n\n# Example:\n#   a(10^1) = 122\n#   a(10^2) = 18065\n#   a(10^3) = 2475190\n#   a(10^4) = 317257140\n#   a(10^5) = 38717197452\n#   a(10^6) = 4571629173912\n#   a(10^7) = 527148712519016\n#   a(10^8) = 59713873168012716\n#   a(10^9) = 6671288261316915052\n\n# This algorithm can be vastly improved.\n\n# See also:\n#   https://oeis.org/A018804\n#   https://oeis.org/A272718\n#   https://en.wikipedia.org/wiki/Mertens_function\n#   https://en.wikipedia.org/wiki/M%C3%B6bius_function\n#   https://en.wikipedia.org/wiki/Euler%27s_totient_function\n#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::GMPz   qw();\nuse experimental qw(signatures);\nuse ntheory      qw(euler_phi moebius mertens sqrtint forsquarefree);\n\nsub euler_totient_partial_sum ($n) {\n\n    my $total = Math::GMPz->new(0);\n\n    my $s = sqrtint($n);\n    my $u = int($n / ($s + 1));\n\n    my $prev = mertens($n);\n\n    for my $k (1 .. $s) {\n        my $curr = mertens(int($n / ($k + 1)));\n        $total += ($prev - $curr) * $k * ($k + 1);\n        $prev = $curr;\n    }\n\n    forsquarefree {\n        my $t = int($n / $_);\n        $total += moebius($_) * $t * ($t + 1);\n    } $u;\n\n    return $total / 2;\n}\n\nsub gcd_sum_partial_sum($n) {\n\n    my $total = Math::GMPz->new(0);\n\n    my $s = sqrtint($n);\n    my $u = int($n / ($s + 1));\n\n    my $prev = euler_totient_partial_sum($n);\n\n    for my $k (1 .. $s) {\n        my $curr = euler_totient_partial_sum(int($n / ($k + 1)));\n        $total += ($prev - $curr) * $k * ($k + 1);\n        $prev = $curr;\n    }\n\n    for my $k (1 .. $u) {\n        my $t = int($n / $k);\n        $total += euler_phi($k) * $t * ($t + 1);\n    }\n\n    return $total / 2;\n}\n\nsub gcd_sum_partial_sum_dirichlet($n) {\n\n    my $total = Math::GMPz->new(0);\n\n    my $s = sqrtint($n);\n\n    for my $k (1 .. $s) {\n        my $t = int($n / $k);\n        $total += $k * euler_totient_partial_sum($t);\n        $total += euler_phi($k) * (($t * ($t + 1)) >> 1);\n    }\n\n    $total -= euler_totient_partial_sum($s) * (($s * ($s + 1)) >> 1);\n\n    return $total;\n}\n\nsub gcd_sum_partial_sum_test ($n) {    # just for testing\n    my $sum = Math::GMPz->new(0);\n\n    foreach my $k (1 .. $n) {\n        my $t = int($n / $k);\n        $sum += euler_phi($k) * $t * ($t + 1);\n    }\n\n    return $sum / 2;\n}\n\nfor my $m (0 .. 10) {\n\n    my $n = int rand 10000;\n\n    my $t1 = gcd_sum_partial_sum($n);\n    my $t2 = gcd_sum_partial_sum_dirichlet($n);\n    my $t3 = gcd_sum_partial_sum_test($n);\n\n    die \"error: $t1 != $t2\" if ($t1 != $t2);\n    die \"error: $t1 != $t3\" if ($t1 != $t3);\n\n    say \"Sum_{k=1..$n} G(k) = $t1\";\n}\n\n__END__\nSum_{k=1..6249} G(k) = 118276019\nSum_{k=1..6470} G(k) = 127257585\nSum_{k=1..1271} G(k) = 4109678\nSum_{k=1..4849} G(k) = 69427261\nSum_{k=1..6771} G(k) = 140029473\nSum_{k=1..5078} G(k) = 76492429\nSum_{k=1..1262} G(k) = 4054055\nSum_{k=1..7751} G(k) = 185959182\nSum_{k=1..4188} G(k) = 51033167\nSum_{k=1..5283} G(k) = 83132565\nSum_{k=1..2574} G(k) = 18289119\n"
  },
  {
    "path": "Math/partial_sums_of_gcd-sum_function_fast.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 04 February 2019\n# https://github.com/trizen\n\n# A sublinear algorithm for computing the partial sums of the gcd-sum function, using Dirichlet's hyperbola method.\n\n# The partial sums of the gcd-sum function is defined as:\n#\n#   a(n) = Sum_{k=1..n} Sum_{d|k} d*phi(k/d)\n#\n# where phi(k) is the Euler totient function.\n\n# Also equivalent with:\n#   a(n) = Sum_{j=1..n} Sum_{i=1..j} gcd(i, j)\n\n# Based on the formula:\n#   a(n) = (1/2)*Sum_{k=1..n} phi(k) * floor(n/k) * floor(1+n/k)\n\n# Example:\n#   a(10^1) = 122\n#   a(10^2) = 18065\n#   a(10^3) = 2475190\n#   a(10^4) = 317257140\n#   a(10^5) = 38717197452\n#   a(10^6) = 4571629173912\n#   a(10^7) = 527148712519016\n#   a(10^8) = 59713873168012716\n#   a(10^9) = 6671288261316915052\n\n# OEIS sequences:\n#   https://oeis.org/A272718 -- Partial sums of gcd-sum sequence A018804.\n#   https://oeis.org/A018804 -- Pillai's arithmetical function: Sum_{k=1..n} gcd(k, n).\n\n# See also:\n#   https://en.wikipedia.org/wiki/Dirichlet_hyperbola_method\n#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(euler_phi moebius sqrtint rootint);\n\nsub partial_sums_of_gcd_sum_function($n) {\n    my $s = sqrtint($n);\n\n    my @mertens_lookup   = (0);\n    my @euler_sum_lookup = (0);\n\n    my $lookup_size = 2 + 2 * rootint($n, 3)**2;\n\n    my @moebius   = moebius(0, $lookup_size);\n    my @euler_phi = euler_phi(0, $lookup_size);\n\n    foreach my $i (1 .. $lookup_size) {\n        $mertens_lookup[$i]   = $mertens_lookup[$i - 1] + $moebius[$i];\n        $euler_sum_lookup[$i] = $euler_sum_lookup[$i - 1] + $euler_phi[$i];\n    }\n\n    my %mertens_cache;\n\n    my sub moebius_partial_sum ($n) {\n\n        if ($n <= $lookup_size) {\n            return $mertens_lookup[$n];\n        }\n\n        if (exists $mertens_cache{$n}) {\n            return $mertens_cache{$n};\n        }\n\n        my $s = sqrtint($n);\n        my $M = 1;\n\n        foreach my $k (2 .. int($n / ($s + 1))) {\n            $M -= __SUB__->(int($n / $k));\n        }\n\n        foreach my $k (1 .. $s) {\n            $M -= $mertens_lookup[$k] * (int($n / $k) - int($n / ($k + 1)));\n        }\n\n        $mertens_cache{$n} = $M;\n    }\n\n    my %euler_phi_sum_cache;\n\n    my sub euler_phi_partial_sum($n) {\n\n        if ($n <= $lookup_size) {\n            return $euler_sum_lookup[$n];\n        }\n\n        if (exists $euler_phi_sum_cache{$n}) {\n            return $euler_phi_sum_cache{$n};\n        }\n\n        my $s = sqrtint($n);\n        my $A = 0;\n\n        foreach my $k (1 .. $s) {\n            my $t = int($n / $k);\n            $A += $k * moebius_partial_sum($t) + $moebius[$k] * (($t * ($t + 1)) >> 1);\n        }\n\n        my $C = moebius_partial_sum($s) * (($s * ($s + 1)) >> 1);\n\n        $euler_phi_sum_cache{$n} = ($A - $C);\n    }\n\n    my $A = 0;\n\n    foreach my $k (1 .. $s) {\n        my $t = int($n / $k);\n        $A += $k * euler_phi_partial_sum($t) + $euler_phi[$k] * (($t * ($t + 1)) >> 1);\n    }\n\n    my $C = euler_phi_partial_sum($s) * (($s * ($s + 1)) >> 1);\n\n    return ($A - $C);\n}\n\nforeach my $n (1 .. 8) {    # takes less than 1 second\n    say \"a(10^$n) = \", partial_sums_of_gcd_sum_function(10**$n);\n}\n"
  },
  {
    "path": "Math/partial_sums_of_gcd-sum_function_faster.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 04 February 2019\n# https://github.com/trizen\n\n# A sublinear algorithm for computing the partial sums of the gcd-sum function, using Dirichlet's hyperbola method.\n\n# The partial sums of the gcd-sum function is defined as:\n#\n#   a(n) = Sum_{k=1..n} Sum_{d|k} d*phi(k/d)\n#\n# where phi(k) is the Euler totient function.\n\n# Also equivalent with:\n#   a(n) = Sum_{j=1..n} Sum_{i=1..j} gcd(i, j)\n\n# Based on the formula:\n#   a(n) = (1/2)*Sum_{k=1..n} phi(k) * floor(n/k) * floor(1+n/k)\n\n# Example:\n#   a(10^1) = 122\n#   a(10^2) = 18065\n#   a(10^3) = 2475190\n#   a(10^4) = 317257140\n#   a(10^5) = 38717197452\n#   a(10^6) = 4571629173912\n#   a(10^7) = 527148712519016\n#   a(10^8) = 59713873168012716\n#   a(10^9) = 6671288261316915052\n\n# OEIS sequences:\n#   https://oeis.org/A272718 -- Partial sums of gcd-sum sequence A018804.\n#   https://oeis.org/A018804 -- Pillai's arithmetical function: Sum_{k=1..n} gcd(k, n).\n\n# See also:\n#   https://en.wikipedia.org/wiki/Dirichlet_hyperbola_method\n#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(euler_phi sqrtint rootint);\n\nsub partial_sums_of_gcd_sum_function($n) {\n    my $s = sqrtint($n);\n\n    my @euler_sum_lookup = (0);\n\n    my $lookup_size = 2 + 2 * rootint($n, 3)**2;\n    my @euler_phi   = euler_phi(0, $lookup_size);\n\n    foreach my $i (1 .. $lookup_size) {\n        $euler_sum_lookup[$i] = $euler_sum_lookup[$i - 1] + $euler_phi[$i];\n    }\n\n    my %seen;\n\n    my sub euler_phi_partial_sum($n) {\n\n        if ($n <= $lookup_size) {\n            return $euler_sum_lookup[$n];\n        }\n\n        if (exists $seen{$n}) {\n            return $seen{$n};\n        }\n\n        my $s = sqrtint($n);\n        my $T = ($n * ($n + 1)) >> 1;\n\n        foreach my $k (2 .. int($n / ($s + 1))) {\n            $T -= __SUB__->(int($n / $k));\n        }\n\n        foreach my $k (1 .. $s) {\n            $T -= (int($n / $k) - int($n / ($k + 1))) * $euler_sum_lookup[$k];\n        }\n\n        $seen{$n} = $T;\n    }\n\n    my $A = 0;\n\n    foreach my $k (1 .. $s) {\n        my $t = int($n / $k);\n        $A += $k * euler_phi_partial_sum($t) + $euler_phi[$k] * (($t * ($t + 1)) >> 1);\n    }\n\n    my $T = ($s * ($s + 1)) >> 1;\n    my $C = euler_phi_partial_sum($s);\n\n    return ($A - $T * $C);\n}\n\nforeach my $n (1 .. 8) {    # takes less than 1 second\n    say \"a(10^$n) = \", partial_sums_of_gcd_sum_function(10**$n);\n}\n"
  },
  {
    "path": "Math/partial_sums_of_generalized_gcd-sum_function.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 25 May 2025\n# https://github.com/trizen\n\n# A sublinear algorithm for computing the partial sums of the generalized gcd-sum function, using Dirichlet's hyperbola method.\n\n# Generalized Pillai's function:\n#   pillai(n,k) = Sum_{d|n} mu(n/d) * d^k * tau(d)\n\n# Multiplicative formula for Sum_{1 <= x_1, x_2, ..., x_k <= n} gcd(x_1, x_2, ..., x_k, n)^k:\n#   a(p^e) = (e - e/p^k + 1) * p^(k*e) = p^((e - 1) * k) * (p^k + e*(p^k - 1))\n\n# The partial sums of the gcd-sum function is defined as:\n#\n#   a(n) = Sum_{k=1..n} Sum_{d|k} d*phi(k/d)\n#\n# where phi(k) is the Euler totient function.\n\n# Also equivalent with:\n#   a(n) = Sum_{j=1..n} Sum_{i=1..j} gcd(i, j)\n\n# Based on the formula:\n#   a(n) = (1/2)*Sum_{k=1..n} phi(k) * floor(n/k) * floor(1+n/k)\n\n# Generalized formula:\n#   a(n,k) = Sum_{x=1..n} J_k(x) * F_k(floor(n/x))\n# where F_k(n) are the Faulhaber polynomials: F_k(n) = Sum_{x=1..n} x^k.\n\n# Example:\n#   a(10^1) = 122\n#   a(10^2) = 18065\n#   a(10^3) = 2475190\n#   a(10^4) = 317257140\n#   a(10^5) = 38717197452\n#   a(10^6) = 4571629173912\n#   a(10^7) = 527148712519016\n#   a(10^8) = 59713873168012716\n#   a(10^9) = 6671288261316915052\n\n#   a(10^1, 2) = 1106\n#   a(10^2, 2) = 1598361\n#   a(10^3, 2) = 2193987154\n#   a(10^4, 2) = 2828894776292\n#   a(10^5, 2) = 3466053625977000\n#   a(10^6, 2) = 4104546122851466704\n#   a(10^7, 2) = 4742992578252739471520\n#   a(10^8, 2) = 5381500783126483704718848\n#   a(10^9, 2) = 6020011093886996189443484608\n\n# OEIS sequences:\n#   https://oeis.org/A272718 -- Partial sums of gcd-sum sequence A018804.\n#   https://oeis.org/A018804 -- Pillai's arithmetical function: Sum_{k=1..n} gcd(k, n).\n\n# See also:\n#   https://en.wikipedia.org/wiki/Dirichlet_hyperbola_method\n#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(faulhaber_sum ipow);\nuse ntheory      qw(jordan_totient sqrtint rootint);\n\nsub partial_sums_of_gcd_sum_function($n, $m) {\n\n    my $s                  = sqrtint($n);\n    my @totient_sum_lookup = (0);\n\n    my $lookup_size    = 2 + 2 * rootint($n, 3)**2;\n    my @jordan_totient = (0);\n\n    foreach my $x (1 .. $lookup_size) {\n        push @jordan_totient, jordan_totient($m, $x);\n    }\n\n    foreach my $i (1 .. $lookup_size) {\n        $totient_sum_lookup[$i] = $totient_sum_lookup[$i - 1] + $jordan_totient[$i];\n    }\n\n    my %seen;\n\n    my sub totient_partial_sum($n) {\n\n        if ($n <= $lookup_size) {\n            return $totient_sum_lookup[$n];\n        }\n\n        if (exists $seen{$n}) {\n            return $seen{$n};\n        }\n\n        my $s = sqrtint($n);\n        my $T = ${faulhaber_sum($n, $m)};\n\n        foreach my $k (2 .. int($n / ($s + 1))) {\n            $T -= __SUB__->(int($n / $k));\n        }\n\n        foreach my $k (1 .. $s) {\n            $T -= (int($n / $k) - int($n / ($k + 1))) * $totient_sum_lookup[$k];\n        }\n\n        $seen{$n} = $T;\n    }\n\n    my $A = 0;\n\n    foreach my $k (1 .. $s) {\n        my $t = int($n / $k);\n        $A += ${ipow($k, $m)} * totient_partial_sum($t) + $jordan_totient[$k] * ${faulhaber_sum($t, $m)};\n    }\n\n    my $T = ${faulhaber_sum($s, $m)};\n    my $C = totient_partial_sum($s);\n\n    return ($A - $T * $C);\n}\n\nforeach my $n (1 .. 8) {    # takes less than 1 second\n    say \"a(10^$n, 1) = \", partial_sums_of_gcd_sum_function(10**$n, 1);\n}\n\nsay '';\n\nforeach my $n (1 .. 8) {    # takes less than 1 second\n    say \"a(10^$n, 2) = \", partial_sums_of_gcd_sum_function(10**$n, 2);\n}\n"
  },
  {
    "path": "Math/partial_sums_of_gpf.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 20 July 2020\n# https://github.com/trizen\n\n# Algorithm with sublinear time for computing:\n#\n#   Sum_{k=2..n} gpf(k)\n#\n# where:\n#   gpf(k) = the greatest prime factor of k\n\n# See also:\n#   https://projecteuler.net/problem=642\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub partial_sums_of_gpf($n) {\n\n    my $t = 0;\n    my $s = sqrtint($n);\n\n    forprimes {\n        $t = addint($t, mulint($_, smooth_count(divint($n, $_), $_)));\n    } $s;\n\n    for(my $p = next_prime($s); $p <= $n; $p = next_prime($p)) {\n\n        my $u = divint($n,$p);\n        my $r = divint($n,$u);\n\n        $t = addint($t, mulint($u, sum_primes($p,$r)));\n        $p = $r;\n    }\n\n    return $t;\n}\n\nforeach my $k (1..10) {\n    printf(\"S(10^%d) = %s\\n\", $k, partial_sums_of_gpf(powint(10, $k)));\n}\n\n__END__\nS(10^1)  = 32\nS(10^2)  = 1915\nS(10^3)  = 135946\nS(10^4)  = 10118280\nS(10^5)  = 793111753\nS(10^6)  = 64937323262\nS(10^7)  = 5494366736156\nS(10^8)  = 476001412898167\nS(10^9)  = 41985754895017934\nS(10^10) = 3755757137823525252\nS(10^11) = 339760245382396733607\nS(10^12) = 31019315736720796982142\n"
  },
  {
    "path": "Math/partial_sums_of_inverse_moebius_transform_of_dedekind_function.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 08 March 2019\n# https://github.com/trizen\n\n# Partial sums of the inverse Möbius transform of the Dedekind psi function.\n\n# Definition, for m >= 0:\n#\n#   a(n) = Sum_{k=1..n} Sum_{d|k} ψ_m(d)\n#        = Sum_{k=1..n} Sum_{d|k} 2^omega(k/d) * d^m\n#        = Sum_{k=1..n} 2^omega(k) * F_m(floor(n/k))\n#\n# where `F_n(x)` are the Faulhaber polynomials.\n\n# Asymptotic formula:\n#   Sum_{k=1..n} Sum_{d|k} ψ_m(d) ~ F_m(n) * (zeta(m+1)^2 / zeta(2*(m+1)))\n#                                 ~ (n^(m+1) * zeta(m+1)^2) / ((m+1) * zeta(2*(m+1)))\n\n# For m=1, we have:\n#   a(n) ~ (5/4) * n^2.\n#   a(n) = Sum_{k=1..n} A060648(k).\n#   a(n) = Sum_{k=1..n} Sum_{d|k} 2^omega(k/d) * d.\n#   a(n) = Sum_{k=1..n} Sum_{d|k} A001615(d).\n#   a(n) = (1/2)*Sum_{k=1..n} 2^omega(k) * floor(n/k) * floor(1 + n/k).\n\n# Related OEIS sequences:\n#   https://oeis.org/A064608 -- Partial sums of A034444: sum of number of unitary divisors from 1 to n.\n#   https://oeis.org/A061503 -- Sum_{k<=n} (tau(k^2)), where tau is the number of divisors function.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Dedekind_psi_function\n#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(faulhaber_sum);\nuse ntheory qw(sqrtint rootint factor_exp moebius);\n\nsub inverse_moebius_of_dedekind_partial_sum ($n, $m) {\n\n    my $lookup_size = 2 + 2 * rootint($n, 3)**2;\n\n    my @omega_lookup     = (0);\n    my @omega_sum_lookup = (0);\n\n    for my $k (1 .. $lookup_size) {\n        $omega_lookup[$k]     = 2**factor_exp($k);\n        $omega_sum_lookup[$k] = $omega_sum_lookup[$k - 1] + $omega_lookup[$k];\n    }\n\n    my $s  = sqrtint($n);\n    my @mu = moebius(0, $s);\n\n    my sub R($n) {    # A064608(n) = Sum_{k=1..n} 2^omega(k)\n\n        if ($n <= $lookup_size) {\n            return $omega_sum_lookup[$n];\n        }\n\n        my $total = 0;\n\n        foreach my $k (1 .. sqrtint($n)) {\n\n            $mu[$k] || next;\n\n            my $tmp = 0;\n            foreach my $j (1 .. sqrtint(int($n / $k / $k))) {\n                $tmp += int($n / $j / $k / $k);\n            }\n\n            $total += $mu[$k] * (2 * $tmp - sqrtint(int($n / $k / $k))**2);\n        }\n\n        return $total;\n    }\n\n    my $total = 0;\n\n    for my $k (1 .. $s) {\n        $total += $omega_lookup[$k] * faulhaber_sum(int($n / $k), $m);\n        $total += $k**$m * R(int($n / $k));\n    }\n\n    $total -= R($s) * faulhaber_sum($s, $m);\n\n    return $total;\n}\n\nsub inverse_moebius_of_dedekind_partial_sum_test ($n, $m) {    # just for testing\n    my $total = 0;\n\n    foreach my $k (1 .. $n) {\n        $total += 2**factor_exp($k) * faulhaber_sum(int($n / $k), $m);\n    }\n\n    return $total;\n}\n\nfor my $m (0 .. 10) {\n\n    my $n = int(rand(1000));\n\n    my $t1 = inverse_moebius_of_dedekind_partial_sum($n, $m);\n    my $t2 = inverse_moebius_of_dedekind_partial_sum_test($n, $m);\n\n    die \"error: $t1 != $t2\" if $t1 != $t2;\n\n    say \"Sum_{k=1..$n} Sum_{d|k} ψ_$m(d) = $t1\";\n}\n\n__END__\nSum_{k=1..399} Sum_{d|k} ψ_0(d) = 7125\nSum_{k=1..898} Sum_{d|k} ψ_1(d) = 1005565\nSum_{k=1..284} Sum_{d|k} ψ_2(d) = 10904384\nSum_{k=1..363} Sum_{d|k} ψ_3(d) = 5089543732\nSum_{k=1..676} Sum_{d|k} ψ_4(d) = 30446345621064\nSum_{k=1..719} Sum_{d|k} ψ_5(d) = 23921678049099402\nSum_{k=1..273} Sum_{d|k} ψ_6(d) = 16623157368659789\nSum_{k=1..291} Sum_{d|k} ψ_7(d) = 6568878240105603914\nSum_{k=1..668} Sum_{d|k} ψ_8(d) = 2974535697414122138503228\nSum_{k=1..772} Sum_{d|k} ψ_9(d) = 7583168029177266313981257004\nSum_{k=1..967} Sum_{d|k} ψ_10(d) = 63269226338847691226388054366024\n"
  },
  {
    "path": "Math/partial_sums_of_jordan_totient_function.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 21 November 2018\n# https://github.com/trizen\n\n# A new algorithm for computing the partial-sums of the Jordan totient function `J_m(k)`, for `1 <= k <= n`:\n#\n#   Sum_{k=1..n} J_m(k)\n#\n# for any fixed integer m >= 1.\n\n# Based on the formula:\n#   Sum_{k=1..n} J_m(k) = Sum_{k=1..n} moebius(k) * F(m, floor(n/k))\n#\n# where F(n,x) is Faulhaber's formula for `Sum_{k=1..x} k^n`, defined in terms of Bernoulli polynomials as:\n#   F(n, x) = (Bernoulli(n+1, x+1) - Bernoulli(n+1, 1)) / (n+1)\n\n# Example for a(n) = Sum_{k=1..n} J_2(k):\n#  a(10^1) = 312\n#  a(10^2) = 280608\n#  a(10^3) = 277652904\n#  a(10^4) = 277335915120\n#  a(10^5) = 277305865353048\n#  a(10^6) = 277302780859485648\n#  a(10^7) = 277302491422450102032\n#  a(10^8) = 277302460845902192282712\n#  a(10^9) = 277302457878113251222146576\n\n# Asymptotic formula:\n#   Sum_{k=1..n} J_2(k) ~ n^3 / (3*zeta(3))\n\n# In general, for m>=1:\n#   Sum_{k=1..n} J_m(k) ~ n^(m+1) / ((m+1) * zeta(m+1))\n\n# See also:\n#   https://oeis.org/A321879\n#   https://en.wikipedia.org/wiki/Mertens_function\n#   https://en.wikipedia.org/wiki/M%C3%B6bius_function\n#   https://en.wikipedia.org/wiki/Jordan%27s_totient_function\n#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(faulhaber_sum ipow);\nuse ntheory qw(jordan_totient moebius mertens vecsum sqrtint forsquarefree is_square_free);\n\nsub jordan_totient_partial_sum ($n, $m) {\n\n    my $total = 0;\n\n    my $s = sqrtint($n);\n    my $u = int($n / ($s + 1));\n\n    my $prev = mertens($n);\n\n    for my $k (1 .. $s) {\n        my $curr = mertens(int($n / ($k + 1)));\n        $total += ($prev - $curr) * faulhaber_sum($k, $m);\n        $prev = $curr;\n    }\n\n    forsquarefree {\n        $total += moebius($_) * faulhaber_sum(int($n / $_), $m);\n    } $u;\n\n    return $total;\n}\n\nsub jordan_totient_partial_sum_2 ($n, $m) {\n\n    my $total = 0;\n    my $s = sqrtint($n);\n\n    for my $k (1 .. $s) {\n        $total += ipow($k, $m) * mertens(int($n/$k));\n        $total += moebius($k) * faulhaber_sum(int($n/$k), $m) if is_square_free($k);\n    }\n\n    $total -= faulhaber_sum($s, $m) * mertens($s);\n\n    return $total;\n}\n\nsub jordan_totient_partial_sum_test ($n, $m) {    # just for testing\n    vecsum(map { jordan_totient($m, $_) } 1 .. $n);\n}\n\nfor my $m (0 .. 10) {\n\n    my $n = int rand 10000;\n\n    my $t1 = jordan_totient_partial_sum($n, $m);\n    my $t2 = jordan_totient_partial_sum_2($n, $m);\n    my $t3 = jordan_totient_partial_sum_test($n, $m);\n\n    die \"error: $t1 != $t2\" if ($t1 != $t2);\n    die \"error: $t1 != $t3\" if ($t1 != $t3);\n\n    say \"Sum_{k=1..$n} J_$m(k) = $t1\";\n}\n\n__END__\nSum_{k=1..3244} J_0(k) = 1\nSum_{k=1..5688} J_1(k) = 9834896\nSum_{k=1..9961} J_2(k) = 274117576704\nSum_{k=1..2548} J_3(k) = 9743111756724\nSum_{k=1..1147} J_4(k) = 383774380194000\nSum_{k=1..9985} J_5(k) = 162406071542610636006836\nSum_{k=1..8677} J_6(k) = 524873561219508820442845176\nSum_{k=1..3594} J_7(k) = 3469354096873688451827581144\nSum_{k=1..6424} J_8(k) = 2067471378951107437291216947429120\nSum_{k=1..5169} J_9(k) = 1361614000750853225756775763744598788\nSum_{k=1..7785} J_10(k) = 578821237542299170578127992588067328813064\n"
  },
  {
    "path": "Math/partial_sums_of_jordan_totient_function_fast.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 04 February 2019\n# https://github.com/trizen\n\n# A sublinear algorithm for computing the partial sums of the Jordan totient function.\n\n# The partial sums of the Jordan totient function is defined as:\n#\n#   a_m(n) = Sum_{k=1..n} J_m(k)\n#\n# where J_m(k) is the Jordan totient function.\n\n# Recursive formula:\n#\n#   a_m(n) = F_m(n) - Sum_{k=2..sqrt(n)} a_m(floor(n/k)) - Sum_{k=1..floor(n/sqrt(n))-1} a_m(k) * (floor(n/k) - floor(n/(k+1)))\n#\n# where F_m(x) are Faulhaber's polynomials.\n\n# Example for a_2(n) = Sum_{k=1..n} J_2(k):\n#    a_2(10^1) = 312\n#    a_2(10^2) = 280608\n#    a_2(10^3) = 277652904\n#    a_2(10^4) = 277335915120\n#    a_2(10^5) = 277305865353048\n#    a_2(10^6) = 277302780859485648\n#    a_2(10^7) = 277302491422450102032\n#    a_2(10^8) = 277302460845902192282712\n#    a_2(10^9) = 277302457878113251222146576\n\n# Asymptotic formula:\n#   Sum_{k=1..n} J_2(k) ~ n^3 / (3*zeta(3))\n\n# In general, for m>=1:\n#   Sum_{k=1..n} J_m(k) ~ n^(m+1) / ((m+1) * zeta(m+1))\n\n# OEIS sequences:\n#   https://oeis.org/A002088 -- Sum of totient function: a(n) = Sum_{k=1..n} phi(k).\n#   https://oeis.org/A064018 -- Sum of the Euler totients phi for 10^n.\n#   https://oeis.org/A272718 -- Partial sums of gcd-sum sequence A018804.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Faulhaber's_formula\n#   https://en.wikipedia.org/wiki/Dirichlet_hyperbola_method\n#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Math::GMPz qw();\nuse Math::AnyNum qw(faulhaber_sum);\nuse ntheory qw(sqrtint rootint jordan_totient);\n\nsub partial_sums_of_jordan_totient ($n, $m) {\n    my $s = sqrtint($n);\n\n    my $lookup_size       = 2 * rootint($n, 3)**2;\n    my @jordan_sum_lookup = (Math::GMPz->new(0));\n\n    foreach my $i (1 .. $lookup_size) {\n        $jordan_sum_lookup[$i] = $jordan_sum_lookup[$i - 1] + jordan_totient($m, $i);\n    }\n\n    my %seen;\n\n    sub ($n) {\n\n        if ($n <= $lookup_size) {\n            return $jordan_sum_lookup[$n];\n        }\n\n        if (exists $seen{$n}) {\n            return $seen{$n};\n        }\n\n        my $s = sqrtint($n);\n        my $A = ${faulhaber_sum($n, $m)};\n\n        foreach my $k (2 .. int($n / ($s + 1))) {\n            $A -= __SUB__->(int($n / $k));\n        }\n\n        foreach my $k (1 .. $s) {\n            $A -= (int($n / $k) - int($n / ($k + 1))) * $jordan_sum_lookup[$k];\n        }\n\n        $seen{$n} = $A;\n\n    }->($n);\n}\n\nforeach my $n (1 .. 8) {    # takes ~1.5 seconds\n    say \"a_2(10^$n) = \", partial_sums_of_jordan_totient(10**$n, 2);\n}\n"
  },
  {
    "path": "Math/partial_sums_of_jordan_totient_function_times_k_to_the_m.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 07 February 2019\n# https://github.com/trizen\n\n# A sublinear algorithm for computing the partial sums of the Jordan totient function times k^m.\n\n# The partial sums of the Jordan totient function is defined as:\n#\n#   a(n,j,m) = Sum_{k=1..n} k^m * J_j(k)\n#\n# where J_j(k) is the Jordan totient function.\n\n# Example:\n#   a(10^1, 2, 1) = 2431\n#   a(10^2, 2, 1) = 21128719\n#   a(10^3, 2, 1) = 208327305823\n#   a(10^4, 2, 1) = 2080103011048135\n#   a(10^5, 2, 1) = 20798025097513144783\n#   a(10^6, 2, 1) = 207977166477794042245831\n#   a(10^7, 2, 1) = 2079768770407248541815183631\n#   a(10^8, 2, 1) = 20797684646417657386198683679183\n#   a(10^9, 2, 1) = 207976843496387628847025371255443991\n\n# General asymptotic formula:\n#\n#   Sum_{k=1..n} k^m * J_j(k)  ~  F_(m+j)(n) / zeta(j+1).\n#\n# where F_m(n) are the Faulhaber polynomials.\n\n# OEIS sequences:\n#   https://oeis.org/A321879 -- Partial sums of the Jordan function J_2(k), for 1 <= k <= n.\n#   https://oeis.org/A002088 -- Sum of totient function: a(n) = Sum_{k=1..n} phi(k).\n#   https://oeis.org/A064018 -- Sum of the Euler totients phi for 10^n.\n#   https://oeis.org/A272718 -- Partial sums of gcd-sum sequence A018804.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Faulhaber's_formula\n#   https://en.wikipedia.org/wiki/Dirichlet_hyperbola_method\n#   https://en.wikipedia.org/wiki/Jordan%27s_totient_function\n#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(faulhaber_sum ipow);\nuse ntheory qw(jordan_totient sqrtint rootint);\n\nsub partial_sums_of_jordan_totient ($n, $j, $m) {\n    my $s = sqrtint($n);\n\n    my @jordan_sum_lookup = (0);\n    my $lookup_size = 2 * rootint($n, 3)**2;\n\n    foreach my $i (1 .. $lookup_size) {\n        $jordan_sum_lookup[$i] = $jordan_sum_lookup[$i - 1] + ipow($i, $m) * jordan_totient($j, $i);\n    }\n\n    my %seen;\n\n    sub ($n) {\n\n        if ($n <= $lookup_size) {\n            return $jordan_sum_lookup[$n];\n        }\n\n        if (exists $seen{$n}) {\n            return $seen{$n};\n        }\n\n        my $s = sqrtint($n);\n        my $T = faulhaber_sum($n, $m + $j);\n\n        foreach my $k (2 .. int($n / ($s + 1))) {\n            $T -= ipow($k, $m) * __SUB__->(int($n / $k));\n        }\n\n        foreach my $k (1 .. $s) {\n            $T -= (faulhaber_sum(int($n / $k), $m) - faulhaber_sum(int($n / ($k + 1)), $m)) * $jordan_sum_lookup[$k];\n        }\n\n        $seen{$n} = $T;\n\n    }->($n);\n}\n\nmy $j = 2;\nmy $k = 1;\n\nforeach my $n (1 .. 7) {    # takes ~2.9 seconds\n    say \"a(10^$n, $j, $k) = \", partial_sums_of_jordan_totient(10**$n, $j, $k);\n}\n"
  },
  {
    "path": "Math/partial_sums_of_lcm_count_function.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 09 January 2021\n# https://github.com/trizen\n\n# Let f(n) be the number of couples (x,y) with x and y positive integers, x ≤ y and the least common multiple of x and y equal to n.\n\n# Let a(n) = A007875(n), with a(1) = 1, for n > 1 (due to Vladeta Jovovic, Jan 25 2002):\n#   a(n) = (1/2)*Sum_{d|n} abs(mu(d))\n#        = 2^(omega(n)-1)\n#        = usigma_0(n)/2\n\n# This gives us f(n) as:\n#   f(n) = Sum_{d|n} a(d)\n\n# This script implements a sub-linear formula for computing partial sums of f(n):\n#   S(n) = Sum_{k=1..n} f(k)\n#        = Sum_{k=1..n} Sum_{d|k} a(d)\n#        = Sum_{k=1..n} a(k) * floor(n/k)\n\n# See also:\n#   https://oeis.org/A007875\n#   https://oeis.org/A064608\n#   https://oeis.org/A182082\n\n# Problem from:\n#   https://projecteuler.net/problem=379\n\n# Several values for S(10^n):\n#   S(10^1)  = 29\n#   S(10^2)  = 647\n#   S(10^3)  = 11751\n#   S(10^4)  = 186991\n#   S(10^5)  = 2725630\n#   S(10^6)  = 37429395\n#   S(10^7)  = 492143953\n#   S(10^8)  = 6261116500\n#   S(10^9)  = 77619512018\n#   S(10^10) = 942394656385\n#   S(10^11) = 11247100884096\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub S ($n) {\n\n    my $lookup_size = 2 + 2 * rootint($n, 3)**2;\n\n    $lookup_size = 50000000    if ($lookup_size > 50000000);\n    $lookup_size = sqrtint($n) if ($lookup_size < sqrtint($n));\n\n    my @omega_lookup     = (0);\n    my @omega_sum_lookup = (0);\n\n    for my $k (1 .. $lookup_size) {\n        $omega_lookup[$k]     = ($k == 1) ? 0 : (1 << (factor_exp($k) - 1));\n        $omega_sum_lookup[$k] = $omega_sum_lookup[$k - 1] + $omega_lookup[$k];\n    }\n\n    my $s  = sqrtint($n);\n    my @mu = moebius(0, $s);\n\n    my sub R ($n) {\n\n        if ($n <= $lookup_size) {\n            return $omega_sum_lookup[$n];\n        }\n\n        my $total = 0;\n\n        foreach my $k (1 .. sqrtint($n)) {\n\n            $mu[$k] || next;\n\n            my $t = 0;\n            my $r = sqrtint(divint($n, $k * $k));\n\n            foreach my $j (1 .. $r) {\n                $t += divint($n, $j * $k * $k);\n            }\n\n            $total += $mu[$k] * (2 * $t - $r * $r);\n        }\n\n        return (($total - 1) >> 1);\n    }\n\n    my $total = 0;\n\n    for my $k (1 .. $s) {\n        $total += $omega_lookup[$k] * divint($n, $k);\n        $total += R(divint($n, $k));\n    }\n\n    $total -= R($s) * $s;\n\n    return $total + $n;\n}\n\nforeach my $n (1 .. 9) {\n    say \"S(10^$n) = \", S(10**$n);\n}\n"
  },
  {
    "path": "Math/partial_sums_of_liouville_function.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 04 April 2019\n# https://github.com/trizen\n\n# A sublinear algorithm for computing the summatory function of the Liouville function (partial sums of the Liouville function).\n\n# Defined as:\n#\n#   L(n) = Sum_{k=1..n} λ(k)\n#\n# where λ(k) is the Liouville function.\n\n# Example:\n#   L(10^1) = 0\n#   L(10^2) = -2\n#   L(10^3) = -14\n#   L(10^4) = -94\n#   L(10^5) = -288\n#   L(10^6) = -530\n#   L(10^7) = -842\n#   L(10^8) = -3884\n#   L(10^9) = -25216\n#   L(10^10) = -116026\n\n# OEIS sequences:\n#   https://oeis.org/A008836 -- Liouville's function lambda(n) = (-1)^k, where k is number of primes dividing n (counted with multiplicity).\n#   https://oeis.org/A090410 -- L(10^n), where L(n) is the summatory function of the Liouville function.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Liouville_function\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(liouville sqrtint rootint);\n\nsub liouville_function_sum($n) {\n\n    my $lookup_size = 2 * rootint($n, 3)**2;\n\n    my @liouville_lookup = (0);\n\n    foreach my $i (1 .. $lookup_size) {\n        $liouville_lookup[$i] = $liouville_lookup[$i - 1] + liouville($i);\n    }\n\n    my %seen;\n\n    sub ($n) {\n\n        if ($n <= $lookup_size) {\n            return $liouville_lookup[$n];\n        }\n\n        if (exists $seen{$n}) {\n            return $seen{$n};\n        }\n\n        my $s = sqrtint($n);\n        my $L = $s;\n\n        foreach my $k (2 .. int($n / ($s + 1))) {\n            $L -= __SUB__->(int($n / $k));\n        }\n\n        foreach my $k (1 .. $s) {\n            $L -= $liouville_lookup[$k] * (int($n / $k) - int($n / ($k + 1)));\n        }\n\n        $seen{$n} = $L;\n\n    }->($n);\n}\n\nforeach my $n (1 .. 9) {    # takes ~2.6 seconds\n    say \"L(10^$n) = \", liouville_function_sum(10**$n);\n}\n"
  },
  {
    "path": "Math/partial_sums_of_lpf.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 20 July 2020\n# https://github.com/trizen\n\n# Algorithm with sublinear time for computing:\n#\n#   Sum_{k=2..n} lpf(k)\n#\n# where:\n#   lpf(k) = the least prime factor of k\n\n# See also:\n#   https://projecteuler.net/problem=521\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub partial_sums_of_lpf($n) {\n\n    my $t = 0;\n    my $s = sqrtint($n);\n\n    forprimes {\n        $t = addint($t, mulint($_, rough_count(divint($n,$_), $_)));\n    } $s;\n\n    addint($t, sum_primes(next_prime($s), $n));\n}\n\nforeach my $k (1..10) {\n    printf(\"S(10^%d) = %s\\n\", $k, partial_sums_of_lpf(powint(10, $k)));\n}\n\n__END__\nS(10^1)  = 28\nS(10^2)  = 1257\nS(10^3)  = 79189\nS(10^4)  = 5786451\nS(10^5)  = 455298741\nS(10^6)  = 37568404989\nS(10^7)  = 3203714961609\nS(10^8)  = 279218813374515\nS(10^9)  = 24739731010688477\nS(10^10) = 2220827932427240957\nS(10^11) = 201467219561892846337\nS(10^12) = 18435592284459044389811\n"
  },
  {
    "path": "Math/partial_sums_of_n_over_k-almost_prime_divisors.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 20 July 2020\n# https://github.com/trizen\n\n# Sublinear algorithm for computing the following partial sum:\n#   S(n) = Sum_{k=1..n} Sum_{d|k, d is r-almost prime} (k/d)^m\n\n# Equivalently:\n#   S(n) = Sum_{t is r-almost prime <= n} F_m(floor(n/t))\n# where F_m(x) are the Faulhaber polynomials.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\nuse Math::AnyNum qw(faulhaber_sum ipow);\n\nsub f($n, $r = 1, $m = 0) {\n\n    my $total = 0;\n    my $s = sqrtint($n);\n\n    for my $k (1 .. $s) {\n        $total += ipow($k, $m) * almost_prime_count($r, int($n/$k));\n        $total += faulhaber_sum(int($n/$k), $m) if is_almost_prime($r, $k);\n    }\n\n    $total -= faulhaber_sum($s, $m) * almost_prime_count($r, $s);\n    $total;\n}\n\nmy $n = 100;\n\nsay f($n, 1, 0);      #=> Sum_{p     <= n} floor(n/p)       = Sum_{k=1..n} omega(k)\nsay f($n, 2, 0);      #=> Sum_{p*q   <= n} floor(n/(p*q))   = Sum_{k=1..n} (number of semiprime divisors of k)\nsay f($n, 3, 0);      #=> Sum_{p*q*r <= n} floor(n/(p*q*r)) = Sum_{k=1..n} (number of 3-almost prime divisors of k)\n\nsay '';\n\nsay f($n, 1, 1);      #=> Sum_{k=1..n} Sum_{d|k, d is prime} k/d\nsay f($n, 2, 1);      #=> Sum_{k=1..n} Sum_{d|k, d is semiprime} k/d\nsay f($n, 3, 1);      #=> Sum_{k=1..n} Sum_{d|k, d is 3-almost prime} k/d\n\nsay '';\n\nsay f($n, 1, 2);      #=> Sum_{k=1..n} Sum_{d|k, d is prime} (k/d)^2\nsay f($n, 2, 2);      #=> Sum_{k=1..n} Sum_{d|k, d is semiprime} (k/d)^2\nsay f($n, 3, 2);      #=> Sum_{k=1..n} Sum_{d|k, d is 3-almost prime} (k/d)^2\n\nsay \"=> Sum_{k=1..10^n} (number of r-almost prime divisors of k)\";\n\nforeach my $r(1..10) {\n    say \"r = $r: {\", join(', ', map{ f(powint(10, $_), $r, 0) } 1..10), \"}\";\n}\n\nsay \"\\n=> Sum_{k=1..10^n} Sum_{d|k, d is r-almost prime} k/d\";\n\nforeach my $r(1..10) {\n    say \"r = $r: {\", join(', ', map{ f(powint(10, $_), $r, 1) } 1..10), \"}\";\n}\n\n__END__\n=> Sum_{k=1..10^n} (number of r-almost prime divisors of k)\nr = 1: {11, 171, 2126, 24300, 266400, 2853708, 30130317, 315037281, 3271067968, 33787242719}\nr = 2: {5, 122, 1913, 25368, 309107, 3587501, 40365331, 444658798, 4824183366, 51743978073}\nr = 3: {1, 58, 1133, 17179, 230719, 2887977, 34547708, 400531419, 4538949470, 50558632114}\nr = 4: {0, 22, 540, 9233, 134679, 1797417, 22659565, 274626874, 3233939674, 37258074465}\nr = 5: {0, 7, 227, 4370, 68530, 965003, 12701142, 159627891, 1939960994, 22982979719}\nr = 6: {0, 2, 87, 1916, 32224, 475757, 6492864, 84065469, 1048002136, 12697321609}\nr = 7: {0, 0, 31, 798, 14434, 222925, 3142601, 41737061, 531430463, 6557159407}\nr = 8: {0, 0, 10, 320, 6254, 101133, 1470682, 19990495, 259291249, 3249251063}\nr = 9: {0, 0, 2, 123, 2636, 44843, 673192, 9358736, 123499047, 1569291893}\nr = 10: {0, 0, 0, 43, 1082, 19518, 303259, 4314150, 57902495, 745552461}\n\n=> Sum_{k=1..10^n} Sum_{d|k, d is r-almost prime} k/d\nr = 1: {25, 2298, 226342, 22616110, 2261266482, 226124236118, 22612374197143, 2261237139656553, 226123710243814636, 22612371006991736766}\nr = 2: {6, 708, 70451, 7039258, 703809052, 70380387011, 7038023049102, 703802183270761, 70380217285372212, 7038021718888470558}\nr = 3: {1, 185, 19261, 1926267, 192581190, 19258134188, 1925810130677, 192580966614994, 19258096515198495, 1925809649512680144}\nr = 4: {0, 45, 4923, 500170, 50040884, 5004660706, 500471363203, 50047175747701, 5004718038062777, 500471809568738447}\nr = 5: {0, 11, 1223, 126815, 12721482, 1272501930, 127253328013, 12725377777502, 1272538042723713, 127253807917463043}\nr = 6: {0, 2, 294, 31833, 3202085, 320487410, 32051378868, 3205166314991, 320516898071185, 32051692261591786}\nr = 7: {0, 0, 71, 7961, 802623, 80380033, 8039296889, 803941592045, 80394302031247, 8039431476576389}\nr = 8: {0, 0, 14, 1987, 200573, 20122035, 2012708079, 201279547587, 20128037882005, 2012804711838236}\nr = 9: {0, 0, 2, 478, 50020, 5033105, 503486440, 50352373220, 5035281352929, 503528648179002}\nr = 10: {0, 0, 0, 106, 12431, 1257575, 125898801, 12591617913, 1259181979675, 125918535892823}\n"
  },
  {
    "path": "Math/partial_sums_of_powerfree_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 20 August 2021\n# https://github.com/trizen\n\n# Sub-linear formula for computing the sum of the k-powerfree numbers <= n.\n\n# See also:\n#   https://oeis.org/A066779\n\nuse 5.036;\nuse ntheory qw(addint mulint divint powint rootint\n               vecprod vecsum forsquarefree vecall factor_exp);\n\nsub T ($n) {    # n-th triangular number\n    divint(mulint($n, addint($n, 1)), 2);\n}\n\nsub is_powerfree ($n, $k = 2) {\n    (vecall { $_->[1] < $k } factor_exp($n)) ? 1 : 0;\n}\n\nsub powerfree_sum ($n, $k = 2) {\n    my $sum = 0;\n    forsquarefree {\n        $sum = addint($sum, vecprod(((scalar(@_) & 1) ? -1 : 1), powint($_, $k), T(divint($n, powint($_, $k)))));\n    } rootint($n, $k);\n    return $sum;\n}\n\nforeach my $k (2 .. 10) {\n    printf(\"Sum of %2d-powerfree numbers <= 10^j: {%s}\\n\", $k,\n           join(', ', map { powerfree_sum(powint(10, $_), $k) } 0 .. 10));\n}\n\nuse Test::More tests => 10;\n\nforeach my $k (1..10) {\n    my $n = 100;\n\n    is_deeply(\n        [map { powerfree_sum($_, $k) } 1..$n],\n        [map { vecsum(grep { is_powerfree($_, $k) } 1..$_) } 1..$n],\n    );\n}\n\n__END__\nSum of  2-powerfree numbers <= 10^j: {1, 34, 2967, 303076, 30420034, 3039711199, 303961062910, 30396557311887, 3039633904822886, 303963567619632057, 30396354343039613622}\nSum of  3-powerfree numbers <= 10^j: {1, 47, 4264, 416150, 41586160, 4159363010, 415954865054, 41595434367696, 4159535757149773, 415953684178098104, 41595368549000401165}\nSum of  4-powerfree numbers <= 10^j: {1, 55, 4633, 462309, 46194572, 4619706557, 461968894786, 46196921076177, 4619691742903970, 461969203230753906, 46196920137396170242}\nSum of  5-powerfree numbers <= 10^j: {1, 55, 4858, 482198, 48222307, 4821980585, 482193364705, 48219363893896, 4821936891554962, 482193669861570387, 48219367054214757071}\nSum of  6-powerfree numbers <= 10^j: {1, 55, 4986, 492091, 49154917, 4914845614, 491476913298, 49147631895757, 4914762949966044, 491476293899695450, 49147629625656526116}\nSum of  7-powerfree numbers <= 10^j: {1, 55, 5050, 496916, 49588762, 4958620842, 495860136228, 49585989492140, 4958599241977593, 495859927007565418, 49585992797893696932}\nSum of  8-powerfree numbers <= 10^j: {1, 55, 5050, 498964, 49798759, 4979743960, 497969661841, 49796960766296, 4979696019857946, 497969600482512058, 49796960053175724454}\nSum of  9-powerfree numbers <= 10^j: {1, 55, 5050, 499988, 49907720, 4989970435, 498998466703, 49899772216835, 4989978143911393, 498997816910227655, 49899781642188970208}\nSum of 10-powerfree numbers <= 10^j: {1, 55, 5050, 500500, 49958920, 4995123879, 499504250712, 49950320120610, 4995032061303318, 499503206523627025, 49950320659515298125}\n"
  },
  {
    "path": "Math/partial_sums_of_powerfree_part.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 20 August 2021\n# https://github.com/trizen\n\n# Sub-linear formula for computing the partial sum of the k-powerfree part of numbers <= n.\n\n# See also:\n#   https://oeis.org/A007913 -- Squarefree part of n: a(n) is the smallest positive number m such that n/m is a square.\n#   https://oeis.org/A050985 -- Cubefree part of n.\n#   https://oeis.org/A069891 -- a(n) = Sum_{k=1..n} A007913(k), the squarefree part of k.\n\nuse 5.036;\nuse ntheory qw(divint addint mulint powint rootint factor_exp vecprod vecsum);\n\nsub T ($n) {    # n-th triangular number\n    divint(mulint($n, addint($n, 1)), 2);\n}\n\nsub powerfree_part ($n, $k = 2) {\n    return 0 if ($n == 0);\n    vecprod(map { powint($_->[0], $_->[1] % $k) } factor_exp($n));\n}\n\nsub f ($n, $r) {\n    vecprod(map { 1 - powint($_->[0], $r) } factor_exp($n));\n}\n\nsub powerfree_part_sum ($n, $k = 2) {\n    my $sum = 0;\n    for (1 .. rootint($n, $k)) {\n        $sum = addint($sum, mulint(f($_, $k), T(divint($n, powint($_, $k)))));\n    }\n    return $sum;\n}\n\nforeach my $k (2 .. 10) {\n    printf(\"Sum of %2d-powerfree part of numbers <= 10^j: {%s}\\n\", $k,\n           join(', ', map { powerfree_part_sum(powint(10, $_), $k) } 0 .. 7));\n}\n\nuse Test::More tests => 10;\n\nforeach my $k (1..10) {\n    my $n = 100;\n\n    is_deeply(\n        [map { powerfree_part_sum($_, $k) } 1..$n],\n        [map { vecsum(map { powerfree_part($_, $k) } 1..$_) } 1..$n],\n    );\n}\n\n__END__\nSum of  2-powerfree part of numbers <= 10^j: {1, 38, 3233, 328322, 32926441, 3289873890, 328984021545, 32898872196712}\nSum of  3-powerfree part of numbers <= 10^j: {1, 48, 4341, 423422, 42307792, 4231510721, 423168867323, 42316819978538}\nSum of  4-powerfree part of numbers <= 10^j: {1, 55, 4655, 464251, 46382816, 4638539465, 463852501943, 46385283123175}\nSum of  5-powerfree part of numbers <= 10^j: {1, 55, 4864, 482704, 48270333, 4826777870, 482672975112, 48267321925901}\nSum of  6-powerfree part of numbers <= 10^j: {1, 55, 4987, 492212, 49167065, 4916054515, 491597851229, 49159726433201}\nSum of  7-powerfree part of numbers <= 10^j: {1, 55, 5050, 496944, 49591853, 4958924582, 495890504497, 49589026540242}\nSum of  8-powerfree part of numbers <= 10^j: {1, 55, 5050, 498970, 49799540, 4979820070, 497977273243, 49797721800745}\nSum of  9-powerfree part of numbers <= 10^j: {1, 55, 5050, 499989, 49907910, 4989989560, 499000372993, 49899962707231}\nSum of 10-powerfree part of numbers <= 10^j: {1, 55, 5050, 500500, 49958965, 4995128633, 499504727624, 49950367771436}\n"
  },
  {
    "path": "Math/partial_sums_of_prime_bigomega_function.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 27 November 2018\n# https://github.com/trizen\n\n# A nice algorithm in terms of the prime-counting function for computing partial sums of the generalized bigomega(n) function:\n#   B_m(n) = Sum_{k=1..n} Ω_m(k)\n\n# For `m=0`, we have:\n#   B_0(n) = bigomega(n!)\n\n# OEIS related sequences:\n#   https://oeis.org/A025528\n#   https://oeis.org/A022559\n#   https://oeis.org/A071811\n#   https://oeis.org/A154945  (0.55169329765699918...)\n#   https://oeis.org/A286229  (0.19411816983263379...)\n\n# Example for `B_0(n)`:\n#    B_0(10^1) = 15\n#    B_0(10^2) = 239\n#    B_0(10^3) = 2877\n#    B_0(10^4) = 31985\n#    B_0(10^5) = 343614\n#    B_0(10^6) = 3626619\n#    B_0(10^7) = 37861249\n#    B_0(10^8) = 392351272\n#    B_0(10^9) = 4044220058\n#    B_0(10^10) = 41518796555\n#    B_0(10^11) = 424904645958\n\n# Example for `B_1(n)`:\n#   B_1(10^1) = 30\n#   B_1(10^2) = 2815\n#   B_1(10^3) = 276337\n#   B_1(10^4) = 27591490\n#   B_1(10^5) = 2758525172\n#   B_1(10^6) = 275847515154\n#   B_1(10^7) = 27584671195911\n#   B_1(10^8) = 2758466558498626\n#   B_1(10^9) = 275846649393437566\n#   B_1(10^10) = 27584664891073330599\n#   B_1(10^11) = 2758466488352698209587\n\n# Example for `B_2(n)`:\n#   B_2(10^1) = 82\n#   B_2(10^2) = 66799\n#   B_2(10^3) = 64901405\n#   B_2(10^4) = 64727468210\n#   B_2(10^5) = 64708096890744\n#   B_2(10^6) = 64706281936598588\n#   B_2(10^7) = 64706077322294843451\n#   B_2(10^8) = 64706058761567362618628\n#   B_2(10^9) = 64706056807390376400359474\n#   B_2(10^10) = 64706056632561375736945155965\n#   B_2(10^11) = 64706056612919470606889256184409\n\n# Asymptotic formulas:\n#   B_1(n) ~ 0.55169329765699918... * n*(n+1)/2\n#   B_2(n) ~ 0.19411816983263379... * n*(n+1)*(2*n+1)/6\n\n# In general, for `m>=1`, we have the following asymptotic formula:\n#   B_m(n) ~ (Sum_{k>=1} primezeta((m+1)*k)) * F_m(n)\n#\n# where F_n(x) is Faulhaber's formula and primezeta(s) is the prime zeta function.\n\n# The prime zeta function is defined as:\n#   primezeta(s) = Sum_{p prime >= 2} 1/p^s\n\n# OEIS sequences:\n#   https://oeis.org/A022559    -- Sum of exponents in prime-power factorization of n!.\n#   https://oeis.org/A071811    -- Sum_{k <= 10^n} number of primes (counted with multiplicity) dividing k.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Prime_zeta_function\n#   https://en.wikipedia.org/wiki/Prime_omega_function\n#   https://en.wikipedia.org/wiki/Prime-counting_function\n#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(faulhaber_sum ipow);\nuse ntheory qw(logint sqrtint rootint prime_count is_prime_power forprimes prime_power_count divint);\n\nsub prime_bigomega_partial_sum ($n, $m) {\n\n    my $s = sqrtint($n);\n    my $u = divint($n, $s+1);\n\n    my $total = 0;\n    my $prev = prime_power_count($n);\n\n    for my $k (1 .. $s) {\n        my $curr = prime_power_count(divint($n, $k+1));\n        $total += faulhaber_sum($k, $m) * ($prev - $curr);\n        $prev = $curr;\n    }\n\n    forprimes {\n        for (my $q = $_; $q <= $u; $q *= $_) {\n            $total += faulhaber_sum(divint($n, $q), $m);\n        }\n    } $u;\n\n    return $total;\n}\n\nsub prime_bigomega_partial_sum_2 ($n, $m) {\n\n    my $s = sqrtint($n);\n    my $total = 0;\n\n    for my $k (1 .. $s) {\n        $total += ipow($k, $m) * prime_power_count(divint($n,$k));\n        $total += faulhaber_sum(divint($n,$k), $m) if is_prime_power($k);\n    }\n\n    $total -= prime_power_count($s) * faulhaber_sum($s, $m);\n\n    return $total;\n}\n\nsub prime_bigomega_partial_sum_test ($n, $m) {    # just for testing\n    my $total = 0;\n\n    foreach my $k (1 .. $n) {\n        if (is_prime_power($k)) {\n            $total += faulhaber_sum(divint($n,$k), $m);\n        }\n    }\n\n    return $total;\n}\n\nfor my $m (0 .. 10) {\n\n    my $n = int rand 100000;\n\n    my $t1 = prime_bigomega_partial_sum($n, $m);\n    my $t2 = prime_bigomega_partial_sum_2($n, $m);\n    my $t3 = prime_bigomega_partial_sum_test($n, $m);\n\n    die \"error: $t1 != $t2\" if ($t1 != $t2);\n    die \"error: $t1 != $t3\" if ($t1 != $t3);\n\n    say \"Sum_{k=1..$n} bigomega_$m(k) = $t1\";\n}\n\n__END__\nSum_{k=1..64129} bigomega_0(k) = 217697\nSum_{k=1..80658} bigomega_1(k) = 1794616247\nSum_{k=1..14117} bigomega_2(k) = 182041102184\nSum_{k=1..42256} bigomega_3(k) = 64820877399946967\nSum_{k=1..94333} bigomega_4(k) = 54949545016977768030431\nSum_{k=1..67787} bigomega_5(k) = 280074038628976042168758675\nSum_{k=1..35346} bigomega_6(k) = 82191526450425222986408201316\nSum_{k=1..26871} bigomega_7(k) = 138516432841564488200009700415893\nSum_{k=1..37827} bigomega_8(k) = 35383863032817120893574255077390725080\nSum_{k=1..75109} bigomega_9(k) = 568264668321999976994584691196910905310669837\nSum_{k=1..86486} bigomega_10(k) = 90982066598399530764623907560522017063257428908802\n"
  },
  {
    "path": "Math/partial_sums_of_prime_omega_function.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 24 November 2018\n# https://github.com/trizen\n\n# A new algorithm for computing the partial-sums of the generalized prime omega function `ω_m(k)`, for `1 <= k <= n`:\n#   A_m(n) = Sum_{k=1..n} ω_m(k)\n#\n# where:\n#     ω_m(n) = n^m * Sum_{p|n} 1/p^m\n\n# Based on the formula:\n#   Sum_{k=1..n} ω_m(k) = Sum_{p prime <= n} F_m(floor(n/p))\n#\n# where F_n(x) is Faulhaber's formula.\n\n# Example for `m=0`:\n#   A_0(10^1) = 11\n#   A_0(10^2) = 171\n#   A_0(10^3) = 2126\n#   A_0(10^4) = 24300\n#   A_0(10^5) = 266400\n#   A_0(10^6) = 2853708\n#   A_0(10^7) = 30130317\n#   A_0(10^8) = 315037281\n#   A_0(10^9) = 3271067968\n#   A_0(10^10) = 33787242719\n#   A_0(10^11) = 347589015681\n#   A_0(10^12) = 3564432632541\n\n# Example for `m=1`:\n#   A_1(10^1) = 25\n#   A_1(10^2) = 2298\n#   A_1(10^3) = 226342\n#   A_1(10^4) = 22616110\n#   A_1(10^5) = 2261266482\n#   A_1(10^6) = 226124236118\n#   A_1(10^7) = 22612374197143\n#   A_1(10^8) = 2261237139656553\n#   A_1(10^9) = 226123710243814636\n#   A_1(10^10) = 22612371006991736766\n#   A_1(10^11) = 2261237100241987653515\n#   A_1(10^12) = 226123710021083492369813\n\n# Example for `m=2`:\n#   A_2(10^1) = 75\n#   A_2(10^2) = 59962\n#   A_2(10^3) = 58403906\n#   A_2(10^4) = 58270913442\n#   A_2(10^5) = 58255785988898\n#   A_2(10^6) = 58254390385024132\n#   A_2(10^7) = 58254229074894448703\n#   A_2(10^8) = 58254214780225801032503\n#   A_2(10^9) = 58254213248247357411667320\n#   A_2(10^10) = 58254213116747777047390609694\n#   A_2(10^11) = 58254213101385832019517484266265\n#   A_2(10^12) = 58254213099991292350208499967189227\n\n# Asymptotic formulas:\n#   A_1(n) ~ 0.4522474200410654985065... * n*(n+1)/2               (see: https://oeis.org/A085548)\n#   A_2(n) ~ 0.1747626392994435364231... * n*(n+1)*(2*n+1)/6       (see: https://oeis.org/A085541)\n\n# For `m >= 1`, `A_m(n)` can be described asymptotically in terms of the prime zeta function:\n#   A_m(n) ~ F_m(n) * P(m+1)\n#\n# where P(s) is defined as:\n#   P(s) = Sum_{p prime >= 2} 1/p^s\n\n# OEIS sequences:\n#   https://oeis.org/A013939     -- Partial sums of sequence A001221 (number of distinct primes dividing n).\n#   https://oeis.org/A064182     -- Sum_{k <= 10^n} number of distinct primes dividing k.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Prime_omega_function\n#   https://en.wikipedia.org/wiki/Prime-counting_function\n#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(faulhaber_sum ipow);\nuse ntheory qw(forprimes prime_count sqrtint is_prime);\n\nsub prime_omega_partial_sum ($n, $m) {     # O(sqrt(n)) complexity\n\n    my $total = 0;\n\n    my $s = sqrtint($n);\n    my $u = int($n / ($s + 1));\n\n    for my $k (1 .. $s) {\n        $total += faulhaber_sum($k, $m) * prime_count(int($n/($k+1))+1, int($n/$k));\n    }\n\n    forprimes {\n        $total += faulhaber_sum(int($n/$_), $m);\n    } $u;\n\n    return $total;\n}\n\nsub prime_omega_partial_sum_2 ($n, $m) {     # O(sqrt(n)) complexity\n\n    my $total = 0;\n    my $s = sqrtint($n);\n\n    for my $k (1 .. $s) {\n        $total += ipow($k, $m) * prime_count(int($n/$k));\n        $total += faulhaber_sum(int($n/$k), $m) if is_prime($k);\n    }\n\n    $total -= faulhaber_sum($s, $m) * prime_count($s);\n\n    return $total;\n}\n\nsub prime_omega_partial_sum_test ($n, $m) {      # just for testing\n    my $total = 0;\n\n    forprimes {\n        $total += faulhaber_sum(int($n/$_), $m);\n    } $n;\n\n    return $total;\n}\n\nfor my $m (0 .. 10) {\n\n    my $n = int rand 100000;\n\n    my $t1 = prime_omega_partial_sum($n, $m);\n    my $t2 = prime_omega_partial_sum_2($n, $m);\n    my $t3 = prime_omega_partial_sum_test($n, $m);\n\n    die \"error: $t1 != $t2\" if ($t1 != $t2);\n    die \"error: $t1 != $t3\" if ($t1 != $t3);\n\n    say \"Sum_{k=1..$n} omega_$m(k) = $t1\";\n}\n\n__END__\nSum_{k=1..93178} omega_0(k) = 247630\nSum_{k=1..60545} omega_1(k) = 828906439\nSum_{k=1..61222} omega_2(k) = 13368082621946\nSum_{k=1..58175} omega_3(k) = 220463446471253532\nSum_{k=1..26576} omega_4(k) = 94816277435320229002\nSum_{k=1..17978} omega_5(k) = 96085844643312478233603\nSum_{k=1..99336} omega_6(k) = 112956550182103434253591001302255\nSum_{k=1..15217} omega_7(k) = 1459563487599016502195229269710\nSum_{k=1..62565} omega_8(k) = 3271462737352430519765722633491562894793\nSum_{k=1..91318} omega_9(k) = 4007044838270388920307792726568428120477189405\nSum_{k=1..28834} omega_10(k) = 514524955177931497535073881648700561462698676\n"
  },
  {
    "path": "Math/partial_sums_of_sigma0_function.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 09 November 2018\n# Edit: 30 March 2025\n# https://github.com/trizen\n\n# Algorithm with O(sqrt(n)) complexity for computing the partial-sums of the `sigma_0(k)` function:\n#   Sum_{k=1..n} sigma_0(k)\n\n# See also:\n#   https://oeis.org/A006218\n#   https://en.wikipedia.org/wiki/Divisor_function\n#   https://en.wikipedia.org/wiki/Faulhaber%27s_formula\n#   https://en.wikipedia.org/wiki/Bernoulli_polynomials\n#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html\n\nuse 5.036;\n\nsub sigma0_partial_sum_faulhaber ($n) {\n\n    my $s   = int(sqrt($n));\n    my $sum = 0;\n\n    foreach my $k (1 .. $s) {\n        $sum += 2 * int($n / $k);\n    }\n\n    return ($sum - $s * $s);\n}\n\nsub sigma0_partial_sum_test ($n) {    # just for testing\n    my $sum = 0;\n    foreach my $k (1 .. $n) {\n        $sum += int($n / $k);\n    }\n    return $sum;\n}\n\nforeach my $m (0 .. 10) {\n\n    my $n = int(rand(1 << (2 * $m)));\n\n    my $t1 = sigma0_partial_sum_test($n);\n    my $t2 = sigma0_partial_sum_faulhaber($n);\n\n    say \"Sum_{k=1..$n} sigma_0(k) = $t2\";\n\n    die \"error: $t1 != $t2\" if ($t1 != $t2);\n}\n\n__END__\nSum_{k=1..0} sigma_0(k) = 0\nSum_{k=1..3} sigma_0(k) = 5\nSum_{k=1..13} sigma_0(k) = 37\nSum_{k=1..30} sigma_0(k) = 111\nSum_{k=1..193} sigma_0(k) = 1049\nSum_{k=1..51} sigma_0(k) = 211\nSum_{k=1..2288} sigma_0(k) = 18059\nSum_{k=1..15985} sigma_0(k) = 157208\nSum_{k=1..10112} sigma_0(k) = 94818\nSum_{k=1..152099} sigma_0(k) = 1838389\nSum_{k=1..446108} sigma_0(k) = 5872025\n"
  },
  {
    "path": "Math/partial_sums_of_sigma_function.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 09 November 2018\n# Edit: 30 March 2025\n# https://github.com/trizen\n\n# A new generalized algorithm with O(sqrt(n)) complexity for computing the partial-sums of the `sigma_j(k)` function:\n#\n#   Sum_{k=1..n} sigma_j(k)\n#\n# for any integer j >= 0.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Divisor_function\n#   https://en.wikipedia.org/wiki/Faulhaber%27s_formula\n#   https://en.wikipedia.org/wiki/Bernoulli_polynomials\n#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html\n\nuse 5.036;\nuse ntheory      qw(divisors);\nuse Math::AnyNum qw(faulhaber_sum bernoulli sum isqrt ipow);\n\nsub sigma_partial_sum_faulhaber ($n, $m = 1) {    # using Faulhaber's formula\n\n    my $s = isqrt($n);\n    my $u = int($n / ($s + 1));\n\n    my $sum = 0;\n\n    foreach my $k (1 .. $s) {\n        $sum += $k * (faulhaber_sum(int($n / $k), $m) - faulhaber_sum(int($n / ($k + 1)), $m));\n    }\n\n    foreach my $k (1 .. $u) {\n        $sum += ipow($k, $m) * int($n / $k);\n    }\n\n    return $sum;\n}\n\nsub sigma_partial_sum_dirichlet ($n, $m = 1) {    # using the Dirichlet hyperbola method\n\n    my $total = 0;\n    my $s     = isqrt($n);\n\n    for my $k (1 .. $s) {\n        $total += faulhaber_sum(int($n / $k), $m);\n        $total += ipow($k, $m) * int($n / $k);\n    }\n\n    $total -= $s * faulhaber_sum($s, $m);\n\n    return $total;\n}\n\nsub sigma_partial_sum_bernoulli ($n, $m = 1) {    # using Bernoulli polynomials\n\n    my $s = isqrt($n);\n    my $u = int($n / ($s + 1));\n\n    my $sum = 0;\n\n    foreach my $k (1 .. $s) {\n        $sum += $k * (bernoulli($m + 1, 1 + int($n / $k)) - bernoulli($m + 1, 1 + int($n / ($k + 1)))) / ($m + 1);\n    }\n\n    foreach my $k (1 .. $u) {\n        $sum += ipow($k, $m) * int($n / $k);\n    }\n\n    return $sum;\n}\n\nsub sigma_partial_sum_test ($n, $m = 1) {    # just for testing\n    sum(\n        map {\n            sum(map { ipow($_, $m) } divisors($_))\n          } 1 .. $n\n       );\n}\n\nforeach my $m (0 .. 10) {\n\n    my $n = int(rand(1000));\n\n    my $t1 = sigma_partial_sum_test($n, $m);\n    my $t2 = sigma_partial_sum_faulhaber($n, $m);\n    my $t3 = sigma_partial_sum_bernoulli($n, $m);\n    my $t4 = sigma_partial_sum_dirichlet($n, $m);\n\n    say \"Sum_{k=1..$n} sigma_$m(k) = $t2\";\n\n    die \"error: $t1 != $t2\" if ($t1 != $t2);\n    die \"error: $t1 != $t3\" if ($t1 != $t3);\n    die \"error: $t1 != $t4\" if ($t1 != $t4);\n}\n\n__END__\nSum_{k=1..198} sigma_0(k) = 1084\nSum_{k=1..657} sigma_1(k) = 355131\nSum_{k=1..933} sigma_2(k) = 325914283\nSum_{k=1..905} sigma_3(k) = 181878297343\nSum_{k=1..402} sigma_4(k) = 2191328841200\nSum_{k=1..967} sigma_5(k) = 139059243381760868\nSum_{k=1..320} sigma_6(k) = 50042081613053611\nSum_{k=1..168} sigma_7(k) = 81561359789498529\nSum_{k=1..977} sigma_8(k) = 90713993807165413835362083\nSum_{k=1..219} sigma_9(k) = 25985664184393953943010\nSum_{k=1..552} sigma_10(k) = 133190310787744370768676943091\n"
  },
  {
    "path": "Math/partial_sums_of_sigma_function_times_k.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 10 November 2018\n# https://github.com/trizen\n\n# A new generalized algorithm with O(sqrt(n)) complexity for computing the partial-sums of `k * sigma_j(k)`, for `1 <= k <= n`:\n#\n#   Sum_{k=1..n} k * sigma_j(k)\n#\n# for any integer j >= 0.\n\n# Example: `a(n) = Sum_{k=1..n} k * sigma(k)`\n#   a(10^1)  = 622\n#   a(10^2)  = 558275\n#   a(10^3)  = 549175530\n#   a(10^4)  = 548429473046\n#   a(10^5)  = 548320905633448\n#   a(10^6)  = 548312690631798482\n#   a(10^7)  = 548311465139943768941\n#   a(10^8)  = 548311366911386862908968\n#   a(10^9)  = 548311356554322895313137239\n#   a(10^10) = 548311355740964925044531454428\n\n# For m>=0 and j>=1, we have the following asymptotic formula:\n#   Sum_{k=1..n} k^m * sigma_j(k) ~ zeta(j+1)/(j+m+1) * n^(j+m+1)\n\n# See also:\n#   https://en.wikipedia.org/wiki/Divisor_function\n#   https://en.wikipedia.org/wiki/Faulhaber%27s_formula\n#   https://en.wikipedia.org/wiki/Bernoulli_polynomials\n#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(divisors);\nuse experimental qw(signatures);\nuse Math::AnyNum qw(faulhaber_sum sum isqrt ipow);\n\nsub sigma_partial_sum($n, $m) {       # O(sqrt(n)) complexity\n\n    my $total = 0;\n\n    my $s = isqrt($n);\n    my $u = int($n / ($s + 1));\n\n    for my $k (1 .. $s) {\n        $total += $k*($k+1) * (faulhaber_sum(int($n/$k), $m+1) - faulhaber_sum(int($n/($k+1)), $m+1));\n    }\n\n    for my $k (1 .. $u) {\n        $total += ipow($k, $m+1) * int($n/$k) * (1 + int($n/$k));\n    }\n\n    return $total/2;\n}\n\nsub sigma_partial_sum_test($n, $m) {      # just for testing\n    sum(map { $_ * sum(map { ipow($_, $m) } divisors($_)) } 1..$n);\n}\n\nfor my $m (0..10) {\n\n    my $n = int(rand(1000));\n\n    my $t1 = sigma_partial_sum($n, $m);\n    my $t2 = sigma_partial_sum_test($n, $m);\n\n    die \"error: $t1 != $t2\" if ($t1 != $t2);\n\n    say \"Sum_{k=1..$n} k * σ_$m(k) = $t2\"\n}\n\n__END__\nSum_{k=1..649} k * σ_0(k) = 1505437\nSum_{k=1..184} k * σ_1(k) = 3442689\nSum_{k=1..156} k * σ_2(k) = 180861250\nSum_{k=1..781} k * σ_3(k) = 63090289257686\nSum_{k=1..822} k * σ_4(k) = 53514505511600484\nSum_{k=1..982} k * σ_5(k) = 128445772086331164364\nSum_{k=1..742} k * σ_6(k) = 11644176895188820029668\nSum_{k=1..837} k * σ_7(k) = 22614022054863154308526282\nSum_{k=1..355} k * σ_8(k) = 3230297764819153302018985\nSum_{k=1..837} k * σ_9(k) = 12937980446016909148074821860258\nSum_{k=1..699} k * σ_10(k) = 1144140317656849776081892799180303\n"
  },
  {
    "path": "Math/partial_sums_of_sigma_function_times_k_to_the_m.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 10 November 2018\n# https://github.com/trizen\n\n# A new generalized algorithm with O(sqrt(n)) complexity for computing the partial-sums of `k^m * sigma_j(k)`, for `1 <= k <= n`:\n#\n#   Sum_{k=1..n} k^m * sigma_j(k)\n#\n# for any fixed m >= 0 and j >= 0.\n\n# Formula:\n#   Sum_{k=1..n} k^m * sigma_j(k) =   Sum_{k=1..floor(sqrt(n))} F(m, k) * (F(m+j, floor(n/k)) - F(m+j, floor(n/(k+1))))\n#                                   + Sum_{k=1..floor(n/(floor(sqrt(n))+1))} k^(m+j) * F(m, floor(n/k))\n#\n# where F(n,x) is Faulhaber's formula for `Sum_{k=1..x} k^n`, defined in terms of Bernoulli polynomials as:\n#\n#   F(n,x) = (Bernoulli(n+1, x+1) - Bernoulli(n+1, 1)) / (n+1)\n#\n# and Bernoulli(n,x) are the Bernoulli polynomials.\n\n# Example for `a(n) = Sum_{k=1..n} k^2 * sigma(k)`\n#   a(10^1)  = 4948\n#   a(10^2)  = 42206495\n#   a(10^3)  = 412181273976\n#   a(10^4)  = 4113599787351824\n#   a(10^5)  = 41124390000844973548\n#   a(10^6)  = 411234935063990235195050\n#   a(10^7)  = 4112336345692801578349555781\n#   a(10^8)  = 41123352884070223300364205949432\n#   a(10^9)  = 411233517733637365707365200123054947\n#   a(10^10) = 4112335168452793891288471658633554668746\n\n# For m>=0 and j>=1, we have the following asymptotic formula:\n#   Sum_{k=1..n} k^m * sigma_j(k) ~ n^(j+m+1) * zeta(j+1) / (j+m+1)\n\n# See also:\n#   https://en.wikipedia.org/wiki/Divisor_function\n#   https://en.wikipedia.org/wiki/Faulhaber%27s_formula\n#   https://en.wikipedia.org/wiki/Bernoulli_polynomials\n#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(divisor_sum);\nuse experimental qw(signatures);\nuse Math::AnyNum qw(faulhaber_sum isqrt ipow sum);\n\nsub sigma_partial_sum ($n, $m, $j) {    # O(sqrt(n)) complexity\n\n    my $total = 0;\n\n    my $s = isqrt($n);\n    my $u = int($n / ($s + 1));\n\n    for my $k (1 .. $s) {\n        $total += faulhaber_sum($k, $m) * (faulhaber_sum(int($n / $k), $m + $j) - faulhaber_sum(int($n / ($k + 1)), $m + $j));\n    }\n\n    for my $k (1 .. $u) {\n        $total += ipow($k, $m + $j) * faulhaber_sum(int($n / $k), $m);\n    }\n\n    return $total;\n}\n\nsub sigma_partial_sum_2 ($n, $m, $j) {    # O(sqrt(n)) complexity\n\n    my $total = 0;\n    my $s = isqrt($n);\n\n    for my $k (1 .. $s) {\n        $total += ipow($k, $m) * faulhaber_sum(int($n / $k), $m + $j);\n        $total += ipow($k, $m + $j) * faulhaber_sum(int($n / $k), $m);\n    }\n\n    $total -= faulhaber_sum($s, $m) * faulhaber_sum($s, $j + $m);\n\n    return $total;\n}\n\nsub sigma_partial_sum_test ($n, $m, $j) {    # just for testing\n    sum(map { ipow($_, $m) * divisor_sum($_, $j) } 1 .. $n);\n}\n\nfor my $m (0 .. 10) {\n\n    my $j = int rand 10;\n    my $n = int rand 1000;\n\n    my $t1 = sigma_partial_sum($n, $m, $j);\n    my $t2 = sigma_partial_sum_2($n, $m, $j);\n    my $t3 = sigma_partial_sum_test($n, $m, $j);\n\n    die \"error: $t1 != $t2\" if ($t1 != $t2);\n    die \"error: $t1 != $t3\" if ($t1 != $t3);\n\n    say \"Sum_{k=1..$n} k^$m * σ_$j(k) = $t1\";\n}\n\n__END__\nSum_{k=1..955} k^0 * σ_7(k) = 87199595877187457268469\nSum_{k=1..765} k^1 * σ_5(k) = 22385163976024509818\nSum_{k=1..805} k^2 * σ_6(k) = 15993292528868648475167542\nSum_{k=1..477} k^3 * σ_2(k) = 2374273670858643\nSum_{k=1..522} k^4 * σ_8(k) = 16674413261032779166355164886215351\nSum_{k=1..983} k^5 * σ_0(k) = 1180528862233337314\nSum_{k=1..293} k^6 * σ_1(k) = 11217015502565855041\nSum_{k=1..906} k^7 * σ_7(k) = 15353361004402823613827018815424339863159897\nSum_{k=1..467} k^8 * σ_2(k) = 25400023350505369496677066803\nSum_{k=1..801} k^9 * σ_4(k) = 3343390385697199861864437708422750691782\nSum_{k=1..142} k^10 * σ_8(k) = 4409116061384423423777822848241899183830\n"
  },
  {
    "path": "Math/partitions_count.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 14 August 2016\n# Website: https://github.com/trizen\n\n# A very fast algorithm for counting the number of partitions of a given number.\n\n# OEIS:\n#   https://oeis.org/A000041\n\n# See also:\n#   https://www.youtube.com/watch?v=iJ8pnCO0nTY\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nno warnings 'recursion';\n\nuse Memoize qw(memoize);\nuse Math::AnyNum qw(:overload floor ceil);\n\nmemoize('partitions_count');\n\n#\n## 3b^2 - b - 2n <= 0\n#\nsub b1 {\n    my ($n) = @_;\n\n    my $x = 3;\n    my $y = -1;\n    my $z = -2 * $n;\n\n    floor((-$y + sqrt($y**2 - 4 * $x * $z)) / (2 * $x));\n}\n\n#\n## 3b^2 + 7b - 2n+4 >= 0\n#\nsub b2 {\n    my ($n) = @_;\n\n    my $x = 3;\n    my $y = 7;\n    my $z = -2 * $n + 4;\n\n    ceil((-$y + sqrt($y**2 - 4 * $x * $z)) / (2 * $x));\n}\n\nsub p {\n    (3 * $_[0]**2 - $_[0]) / 2;\n}\n\n# Based on the recursive function described by Christian Schridde:\n# https://numberworld.blogspot.com/2013/09/sum-of-divisors-function-eulers.html\n\nsub partitions_count {\n    my ($n) = @_;\n\n    return $n if ($n <= 1);\n\n    my $sum_1 = 0;\n    foreach my $i (1 .. b1($n)) {\n        $sum_1 += (-1)**($i - 1) * partitions_count($n - p($i));\n    }\n\n    my $sum_2 = 0;\n    foreach my $i (1 .. b2($n)) {\n        $sum_2 += (-1)**($i - 1) * partitions_count($n - p(-$i));\n    }\n\n    $sum_1 + $sum_2;\n}\n\nforeach my $n (1 .. 100) {\n    say \"p($n) = \", partitions_count($n+1);\n}\n\n__END__\np(1) = 1\np(2) = 2\np(3) = 3\np(4) = 5\np(5) = 7\np(6) = 11\np(7) = 15\np(8) = 22\np(9) = 30\np(10) = 42\np(11) = 56\np(12) = 77\np(13) = 101\np(14) = 135\np(15) = 176\np(16) = 231\np(17) = 297\np(18) = 385\np(19) = 490\np(20) = 627\n"
  },
  {
    "path": "Math/partitions_count_abs.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 26 April 2017\n# Website: https://github.com/trizen\n\n# Simple counting of the number of partitions of n that\n# absolutely sum to n, in the range [-n, n], excluding 0.\n\n# See also:\n#   https://oeis.org/A000041\n\nuse 5.016;\nuse strict;\nuse warnings;\nuse Memoize qw(memoize);\n\nno warnings 'recursion';\n\nmy $atoms;\nsub partitions_count_abs {\n    my ($n, $i, $sum) = @_;\n\n        (abs($sum) == $n)                   ? 1\n      : (abs($sum) > $n || $i > $#{$atoms}) ? 0\n      : ( partitions_count_abs($n, $i, $sum + $atoms->[$i])\n        + partitions_count_abs($n, $i + 1, $sum));\n}\n\nmemoize('partitions_count_abs');\n\nforeach my $n (1 .. 20) {\n    $atoms = [grep { $_ != 0 } (-$n .. $n)];\n    say \"P($n) = \", partitions_count_abs($n, 0, 0);\n}\n\n__END__\nP(1) = 2\nP(2) = 6\nP(3) = 20\nP(4) = 67\nP(5) = 219\nP(6) = 637\nP(7) = 1823\nP(8) = 4748\nP(9) = 12045\nP(10) = 28875\nP(11) = 67320\nP(12) = 150137\nP(13) = 328849\nP(14) = 694865\nP(15) = 1441493\nP(16) = 2915967\nP(17) = 5800757\nP(18) = 11292100\nP(19) = 21683942\nP(20) = 40885671\n"
  },
  {
    "path": "Math/partitions_count_simple.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 24 August 2016\n# Website: https://github.com/trizen\n\n# A very fast algorithm for counting the number of partitions of a given number.\n\n# OEIS:\n#   https://oeis.org/A000041\n\n# See also:\n#   https://www.youtube.com/watch?v=iJ8pnCO0nTY\n#   https://rosettacode.org/wiki/Partition_function_P\n#   https://en.wikipedia.org/wiki/Partition_(number_theory)#Partition_function\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nno warnings 'recursion';\nuse Math::AnyNum qw(floor ceil);\n\n# Based on the recursive function described by Christian Schridde:\n# https://numberworld.blogspot.com/2013/09/sum-of-divisors-function-eulers.html\n\nsub partitions_count {\n    my ($n, $cache) = @_;\n\n    $n <= 1 && return $n;\n\n    if (exists $cache->{$n}) {\n        return $cache->{$n};\n    }\n\n    my @terms;\n\n    foreach my $i (1 .. floor((sqrt(24*$n + 1) + 1) / 6)) {\n        push @terms, (-1)**($i - 1) * partitions_count($n - (($i * (3*$i - 1)) >> 1), $cache);\n    }\n\n    foreach my $i (1 .. ceil((sqrt(24*$n + 1) - 7) / 6)) {\n        push @terms, (-1)**($i - 1) * partitions_count($n - (($i * (3*$i + 1)) >> 1), $cache);\n    }\n\n    $cache->{$n} = Math::AnyNum::sum(@terms);\n}\n\nmy %cache;\n\nforeach my $n (1 .. 100) {\n    say \"p($n) = \", partitions_count($n + 1, \\%cache);\n}\n\n__END__\np(1) = 1\np(2) = 2\np(3) = 3\np(4) = 5\np(5) = 7\np(6) = 11\np(7) = 15\np(8) = 22\np(9) = 30\np(10) = 42\np(11) = 56\np(12) = 77\np(13) = 101\np(14) = 135\np(15) = 176\np(16) = 231\np(17) = 297\np(18) = 385\np(19) = 490\np(20) = 627\n"
  },
  {
    "path": "Math/pascal-fibonacci_triangle.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 25 March 2019\n# https://github.com/trizen\n\n# Generate the Pascal-Fibonacci triangle.\n\n# Definition by Elliott Line, Mar 22 2019:\n#   Consider a version of Pascal's Triangle: a triangular array with a single 1 on row 0,\n#   with numbers below equal to the sum of the two numbers above it if and only if that sum\n#   appears in the Fibonacci sequence. If the sum is not a Fibonacci number, `1` is put in its place.\n\n# OEIS sequence:\n#   https://oeis.org/A307069\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(is_square);\nuse experimental qw(signatures);\n\nsub is_fibonacci($n) {\n    my $m = 5 * $n * $n;\n    is_square($m - 4) or is_square($m + 4);\n}\n\nmy @row  = (1);\nmy $rows = 40;\n\nforeach my $n (1 .. $rows) {\n\n    my @t = (\n        map {\n            my $t = $row[$_] + $row[$_ + 1];\n            is_fibonacci($t) ? $t : 1;\n          } 0 .. ($n - ($n % 2)) / 2 - 1\n    );\n\n    say \"@row\";\n\n    # The triangle is symmetric\n    # See also: https://photos.app.goo.gl/q3981kei8LJyvzgZ9\n    my @u = reverse(@t);\n\n    if ($n % 2 == 0) {\n        shift @u;\n    }\n    @row = (1, @t, @u, 1);\n}\n\n__END__\n1\n1 1\n1 2 1\n1 3 3 1\n1 1 1 1 1\n1 2 2 2 2 1\n1 3 1 1 1 3 1\n1 1 1 2 2 1 1 1\n1 2 2 3 1 3 2 2 1\n1 3 1 5 1 1 5 1 3 1\n1 1 1 1 1 2 1 1 1 1 1\n1 2 2 2 2 3 3 2 2 2 2 1\n1 3 1 1 1 5 1 5 1 1 1 3 1\n1 1 1 2 2 1 1 1 1 2 2 1 1 1\n1 2 2 3 1 3 2 2 2 3 1 3 2 2 1\n1 3 1 5 1 1 5 1 1 5 1 1 5 1 3 1\n1 1 1 1 1 2 1 1 2 1 1 2 1 1 1 1 1\n1 2 2 2 2 3 3 2 3 3 2 3 3 2 2 2 2 1\n1 3 1 1 1 5 1 5 5 1 5 5 1 5 1 1 1 3 1\n1 1 1 2 2 1 1 1 1 1 1 1 1 1 1 2 2 1 1 1\n1 2 2 3 1 3 2 2 2 2 2 2 2 2 2 3 1 3 2 2 1\n1 3 1 5 1 1 5 1 1 1 1 1 1 1 1 5 1 1 5 1 3 1\n1 1 1 1 1 2 1 1 2 2 2 2 2 2 2 1 1 2 1 1 1 1 1\n1 2 2 2 2 3 3 2 3 1 1 1 1 1 1 3 2 3 3 2 2 2 2 1\n1 3 1 1 1 5 1 5 5 1 2 2 2 2 2 1 5 5 1 5 1 1 1 3 1\n1 1 1 2 2 1 1 1 1 1 3 1 1 1 1 3 1 1 1 1 1 2 2 1 1 1\n1 2 2 3 1 3 2 2 2 2 1 1 2 2 2 1 1 2 2 2 2 3 1 3 2 2 1\n1 3 1 5 1 1 5 1 1 1 3 2 3 1 1 3 2 3 1 1 1 5 1 1 5 1 3 1\n1 1 1 1 1 2 1 1 2 2 1 5 5 1 2 1 5 5 1 2 2 1 1 2 1 1 1 1 1\n1 2 2 2 2 3 3 2 3 1 3 1 1 1 3 3 1 1 1 3 1 3 2 3 3 2 2 2 2 1\n1 3 1 1 1 5 1 5 5 1 1 1 2 2 1 1 1 2 2 1 1 1 5 5 1 5 1 1 1 3 1\n1 1 1 2 2 1 1 1 1 1 2 2 3 1 3 2 2 3 1 3 2 2 1 1 1 1 1 2 2 1 1 1\n1 2 2 3 1 3 2 2 2 2 3 1 5 1 1 5 1 5 1 1 5 1 3 2 2 2 2 3 1 3 2 2 1\n1 3 1 5 1 1 5 1 1 1 5 1 1 1 2 1 1 1 1 2 1 1 1 5 1 1 1 5 1 1 5 1 3 1\n1 1 1 1 1 2 1 1 2 2 1 1 2 2 3 3 2 2 2 3 3 2 2 1 1 2 2 1 1 2 1 1 1 1 1\n1 2 2 2 2 3 3 2 3 1 3 2 3 1 5 1 5 1 1 5 1 5 1 3 2 3 1 3 2 3 3 2 2 2 2 1\n1 3 1 1 1 5 1 5 5 1 1 5 5 1 1 1 1 1 2 1 1 1 1 1 5 5 1 1 5 5 1 5 1 1 1 3 1\n1 1 1 2 2 1 1 1 1 1 2 1 1 1 2 2 2 2 3 3 2 2 2 2 1 1 1 2 1 1 1 1 1 2 2 1 1 1\n1 2 2 3 1 3 2 2 2 2 3 3 2 2 3 1 1 1 5 1 5 1 1 1 3 2 2 3 3 2 2 2 2 3 1 3 2 2 1\n1 3 1 5 1 1 5 1 1 1 5 1 5 1 5 1 2 2 1 1 1 1 2 2 1 5 1 5 1 5 1 1 1 5 1 1 5 1 3 1\n"
  },
  {
    "path": "Math/pascal_s_triangle_multiples.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 29 November 2015\n# Website: https://github.com/trizen\n\n# Pascal's triangle with the multiples of a given integer highlighted.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(binomial);\nuse Term::ANSIColor qw(colored);\n\nmy $div  = 3;     # highlight multiples of this integer\nmy $size = 80;    # the size of the triangle\n\nsub pascal {\n    my ($rows) = @_;\n\n    for my $n (1 .. $rows - 1) {\n        say ' ' x ($rows - $n), join \"\",\n          map { $_ % $div == 0 ? colored('.', 'red') : '*' }\n          map { binomial(2*$n, $_) } 0 .. 2*$n;\n    }\n}\n\npascal(int($size / 2));\n"
  },
  {
    "path": "Math/pattern_mixing.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 03 July 2015\n# Website: https://github.com/trizen\n\n#\n# The problem:\n#\n# Mix the stars with the letters in the following pattern,\n# in a random, but uniform way, preserving the original order\n# of letters and preserving the original shape of the pattern.\n#\n\nmy $pattern = <<'EOT';\n ******C*******w*******X*******y*******X*******o*******f******\n igpvAoBLhCffXgIIlyI8gFC8L88vILCg98Io81gaICXpIIg8CIvwFB8I8wXgC\n vIAgLA,L>8CgCCyywcIiF>L=8LX='CgCLfgvC8wXgXKef9B8CIggvIALKXLCv\ny>IgXIXg8w1}CA=y8ylAyw=8Cgyffy8loKK88A8f=,II'gfFFwfvgvCAC8yyLIg\nKXf'''IAX=yiovg>C,8gIAgvAIXFjgCy8Xv89v'XIILy=AC1A8yvov9KvXywffX\n8CFyCC9LvfCvF8gg$yv8vALIIILKsKXyvgCI8yfIKF8L,I9C8BiFwfg,A8h8gF'\nBvgL8C8FfXCC8gB,Iv88AgC8X1CCIFuCX8L>Xi=CCv8ICI8I>KC8IFB8oIFKAvA\nLvgCIg'wBAFLg'1''f=yLLI'ff'fo9gIA>yFv8FIoy'CLfI8f8vk'y8F=vw>gKf\nvy8X        >KLXgKw'og'vF1By'gBvLIXX8KB'XvA'8vofilg        CgC'\nfyBA           8iLIy8IoIvoC,yg,gI=yC8i'I8gL>8'9{           8gB>\nAF18              I8A=vyA'1pfwv,I8lvIABACffIy              AyFC\n1Avpg               Cv'KIyK8C'g9IyFKIL8A=vo               yCABX\nFfv8A                C,9wyIKI,Kn=iXf8wL1w9                8,ygf\nX88oKC                 ICII8'F8ILCLy>>If                 CC8LCy\n XCAIg                  CFAwBvCfyAIgIyA                  BI9'g\n gyIwL8                  lgXIXXXAX8gI8                  8IBiyX\n  FXAygA                  vgoFFFXAggC                  i,LI>I\n   KIXgt                   vXCA8prCI                   gAK=y\n   ******                  *********                  ******\n    *******                 *******                 *******\n     *******                *******                *******\n      ********               *****               ********\n       *********             *****             *********\n        **********           *****           **********\n         ************       *******       ************\n          *******************************************\n           *****************************************\n            ***************************************\n             *************************************\n               *********************************\n                *******************************\n                 *****************************\n                   *************************\n                     *********************\n                       *****************\n                         *************\n                           *********\nEOT\n\n#\n## Solution\n#\n\nmy @chars = split(//, $pattern);\n\nmy @letters = grep { $_ ne '*' and /^\\S/ } @chars;\nmy @stars = grep { $_ eq '*' } @chars;\n\nmy $ratio = @stars / (@letters + @stars);\n\nforeach my $char (@chars) {\n    if ($char =~ /^\\s/) {\n        print $char;\n        next;\n    }\n\n    if (@stars) {\n        if (rand(1) <= $ratio) {\n            print shift @stars;\n            next;\n        }\n    }\n\n    print @letters ? shift(@letters) : shift(@stars);\n}\n"
  },
  {
    "path": "Math/pell_cfrac_factorization.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 10 April 2018\n# https://github.com/trizen\n\n# A simple factorization algorithm, based on ideas from the continued fraction factorization method.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse ntheory qw(is_prime factor_exp vecprod);\nuse Math::AnyNum qw(is_square isqrt irand idiv gcd valuation);\n\nsub pell_cfrac ($n) {\n\n    # Check for primes and negative numbers\n    return ()   if $n <= 1;\n    return ($n) if is_prime($n);\n\n    # Check for perfect squares\n    if (is_square($n)) {\n        my @factors = __SUB__->(isqrt($n));\n        return sort { $a <=> $b } ((@factors) x 2);\n    }\n\n    # Check for divisibility by 2\n    if (!($n & 1)) {\n\n        my $v = valuation($n, 2);\n        my $t = $n >> $v;\n\n        my @factors = (2) x $v;\n\n        if ($t > 1) {\n            push @factors, __SUB__->($t);\n        }\n\n        return @factors;\n    }\n\n    my $x = isqrt($n);\n    my $y = $x;\n    my $z = 1;\n    my $w = 2 * $x;\n    my $k = isqrt($w);\n\n    my $r = $x + $x;\n\n    my ($e1, $e2) = (1, 0);\n    my ($f1, $f2) = (0, 1);\n\n    my %table;\n\n    for (; ;) {\n\n        $y = $r * $z - $y;\n        $z = idiv($n - $y * $y, $z);\n        $r = idiv($x + $y, $z);\n\n        my $u = ($x * $f2 + $e2) % $n;\n        my $v = ($u * $u) % $n;\n\n        my $c = ($v > $w ? $n - $v : $v);\n\n        # Congruence of squares\n        if (is_square($c)) {\n            my $g = gcd($u - isqrt($c), $n);\n\n            if ($g > 1 and $g < $n) {\n                return sort { $a <=> $b } (\n                    __SUB__->($g),\n                    __SUB__->($n / $g)\n                );\n            }\n        }\n\n        my @factors = factor_exp($c);\n        my @odd_powers = grep { $factors[$_][1] % 2 == 1 } 0 .. $#factors;\n\n        if (@odd_powers <= 3) {\n            my $key = join(' ', map { $_->[0] } @factors[@odd_powers]);\n\n            # Congruence of squares by creating a square from previous terms\n            if (exists $table{$key}) {\n                foreach my $d (@{$table{$key}}) {\n\n                    my $g = gcd($d->{u} * $u - isqrt($d->{c} * $c), $n);\n\n                    if ($g > 1 and $g < $n) {\n                        return sort { $a <=> $b } (\n                            __SUB__->($g),\n                            __SUB__->($n / $g)\n                        );\n                    }\n                }\n            }\n\n            push @{$table{$key}}, {c => $c, u => $u};\n\n            # Create easier building blocks for building squares\n            if (@odd_powers >= 2) {\n                foreach my $i (0 .. $#odd_powers) {\n                    my $key = join(' ', map { $_->[0] } @factors[@odd_powers[0 .. $i - 1, $i + 1 .. $#odd_powers]]);\n\n                    if (exists($table{$key}) and @{$table{$key}} < 5) {\n\n                        my $missing_factor = $factors[$odd_powers[$i]][0];\n\n                        next if ($missing_factor > $k);\n\n                        foreach my $d (@{$table{$key}}) {\n                            push @{$table{$missing_factor}},\n                              {\n                                c => $c * $d->{c},\n                                u => $u * $d->{u},\n                              };\n                        }\n                    }\n                }\n            }\n        }\n\n        my $the_end = ($z == 1);\n\n        {\n            ($f1, $f2) = ($f2, ($r * $f2 + $f1) % $n);\n            ($e1, $e2) = ($e2, ($r * $e2 + $e1) % $n);\n\n            # Pell factorization\n            foreach my $t (\n                $e2 + $e2 + $f2 + $x,\n                $e2 + $f2 + $f2,\n                $e2 + $f2 * $x,\n                $e2 + $f2,\n                $e2,\n            ) {\n                my $g = gcd($t, $n);\n\n                if ($g > 1 and $g < $n) {\n                    return sort { $a <=> $b } (\n                        __SUB__->($g),\n                        __SUB__->($n / $g)\n                    );\n                }\n            }\n\n            redo if $the_end;\n        }\n    }\n}\n\nforeach my $k (2 .. 60) {\n\n    my $n = irand(2, 1 << $k);\n    my @f = pell_cfrac($n);\n\n    say \"$n = \", join(' * ', @f);\n\n    die 'error' if grep { !is_prime($_) } @f;\n    die 'error' if vecprod(@f) != $n;\n}\n"
  },
  {
    "path": "Math/pell_factorization.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 03 February 2019\n# https://github.com/trizen\n\n# A simple integer factorization method, using square root convergents.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Pell%27s_equation\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub pell_factorization ($n) {\n\n    my $x = sqrtint($n);\n    my $y = $x;\n    my $z = 1;\n    my $r = 2 * $x;\n    my $w = $r;\n\n    return $n if is_prime($n);\n    return $x if is_square($n);\n\n    my ($f1, $f2) = (1, $x);\n\n    for (; ;) {\n\n        $y = $r*$z - $y;\n        $z = divint($n - $y*$y, $z);\n        $r = divint($x + $y, $z);\n\n        ($f1, $f2) = ($f2, addmod(mulmod($r, $f2, $n), $f1, $n));\n\n        if (is_square($z)) {\n            my $g = gcd($f1 - sqrtint($z), $n);\n            if ($g > 1 and $g < $n) {\n                return $g;\n            }\n        }\n\n        return $n if ($z == 1);\n    }\n}\n\nfor (1 .. 10) {\n    my $n = random_nbit_prime(31) * random_nbit_prime(31);\n    say \"PellFactor($n) = \", pell_factorization($n);\n}\n\n__END__\nPellFactor(2101772756469048319) = 1228264087\nPellFactor(2334333625703344609) = 1709282917\nPellFactor(2358058220132276317) = 1210584887\nPellFactor(1482285997261862561) = 1197377617\nPellFactor(2759217719449375403) = 1559110667\nPellFactor(2828146117168463857) = 1493774729\nPellFactor(1732707024229573211) = 1165003451\nPellFactor(2510049724431882299) = 1820676019\nPellFactor(1585505630716792319) = 1311005599\nPellFactor(1612976091192715981) = 1453708381\n"
  },
  {
    "path": "Math/pell_factorization_anynum.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 03 February 2019\n# https://github.com/trizen\n\n# A simple integer factorization method, using square root convergents.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Pell%27s_equation\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(random_nbit_prime);\nuse Math::AnyNum qw(:all);\nuse experimental qw(signatures);\n\nsub pell_factorization ($n) {\n\n    my $x = isqrt($n);\n    my $y = $x;\n    my $z = 1;\n    my $r = 2 * $x;\n    my $w = $r;\n\n    return $x if is_square($n);\n\n    my ($f1, $f2) = (1, $x);\n\n    for (; ;) {\n\n        $y = $r*$z - $y;\n        $z = idiv($n - $y*$y, $z);\n        $r = idiv($x + $y, $z);\n\n        ($f1, $f2) = ($f2, ($r*$f2 + $f1) % $n);\n\n        if (is_square($z)) {\n            my $g = gcd($f1 - isqrt($z), $n);\n            if ($g > 1 and $g < $n) {\n                return $g;\n            }\n        }\n\n        return $n if ($z == 1);\n    }\n}\n\nfor (1 .. 10) {\n    my $n = random_nbit_prime(25) * random_nbit_prime(25);\n    say \"PellFactor($n) = \", pell_factorization($n);\n}\n\n__END__\nPellFactor(607859142082991) = 20432749\nPellFactor(926859728053057) = 33170069\nPellFactor(523709106944971) = 19544953\nPellFactor(379392152082407) = 18361823\nPellFactor(397926699623521) = 22529261\nPellFactor(596176048102421) = 27540133\nPellFactor(556290216898421) = 21828529\nPellFactor(799063586749279) = 27381929\nPellFactor(513015423767879) = 25622173\nPellFactor(964450431874939) = 30653317\n"
  },
  {
    "path": "Math/perfect_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 09 May 2016\n# https://github.com/trizen\n\n# Generator of perfect numbers, using the fact that\n# the Mth triangular number, where M is a Mersenne\n# prime in the form 2^p-1, gives us a perfect number.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Perfect_number\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum;\nuse ntheory qw(forprimes is_mersenne_prime);\n\nmy $one = Math::AnyNum->one;\n\nforprimes {\n    if (is_mersenne_prime($_)) {\n        my $n = $one << $_;\n        say \"2^($_-1) * (2^$_-1) = \", $n * ($n - 1) / 2;\n    }\n} 1, 100;\n\n__END__\n2^(2-1) * (2^2-1) = 6\n2^(3-1) * (2^3-1) = 28\n2^(5-1) * (2^5-1) = 496\n2^(7-1) * (2^7-1) = 8128\n2^(13-1) * (2^13-1) = 33550336\n2^(17-1) * (2^17-1) = 8589869056\n2^(19-1) * (2^19-1) = 137438691328\n2^(31-1) * (2^31-1) = 2305843008139952128\n2^(61-1) * (2^61-1) = 2658455991569831744654692615953842176\n2^(89-1) * (2^89-1) = 191561942608236107294793378084303638130997321548169216\n"
  },
  {
    "path": "Math/period_of_continued_fraction_for_square_roots.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 31 August 2016\n# License: GPLv3\n# https://github.com/trizen\n\n# Algorithm from:\n#   https://web.math.princeton.edu/mathlab/jr02fall/Periodicity/mariusjp.pdf\n\n# See also:\n#   https://oeis.org/A003285\n#   https://oeis.org/A067280\n#   https://projecteuler.net/problem=64\n#   https://en.wikipedia.org/wiki/Continued_fraction\n#   https://mathworld.wolfram.com/PeriodicContinuedFraction.html\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(is_square sqrtint);\n\nsub period_length {\n    my ($n) = @_;\n\n    my $x = sqrtint($n);\n    my $y = $x;\n    my $z = 1;\n\n    return 0 if is_square($n);\n\n    my $period = 0;\n\n    do {\n        $y = int(($x + $y) / $z) * $z - $y;\n        $z = int(($n - $y * $y) / $z);\n        ++$period;\n    } until ($z == 1);\n\n    return $period;\n}\n\nfor my $i (1 .. 20) {\n    say \"P($i) = \", period_length($i);\n}\n\n__END__\nP(1) = 0\nP(2) = 1\nP(3) = 2\nP(4) = 0\nP(5) = 1\nP(6) = 2\nP(7) = 4\nP(8) = 2\nP(9) = 0\nP(10) = 1\nP(11) = 2\nP(12) = 2\nP(13) = 5\nP(14) = 4\nP(15) = 2\nP(16) = 0\nP(17) = 1\nP(18) = 2\nP(19) = 6\nP(20) = 2\n"
  },
  {
    "path": "Math/period_of_continued_fraction_for_square_roots_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 25 January 2019\n# License: GPLv3\n# https://github.com/trizen\n\n# Compute the period length of the continued fraction for square root of a given number.\n\n# Algorithm from:\n#   https://web.math.princeton.edu/mathlab/jr02fall/Periodicity/mariusjp.pdf\n\n# OEIS sequences:\n#   https://oeis.org/A003285 -- Period of continued fraction for square root of n (or 0 if n is a square).\n#   https://oeis.org/A059927 -- Period length of the continued fraction for sqrt(2^(2n+1)).\n#   https://oeis.org/A064932 -- Period length of the continued fraction for sqrt(3^(2n+1)).\n#   https://oeis.org/A067280 -- Terms in continued fraction for sqrt(n), excl. 2nd and higher periods.\n#   https://oeis.org/A064025 -- Length of period of continued fraction for square root of n!.\n#   https://oeis.org/A064486 -- Quotient cycle lengths of square roots of primorials.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Continued_fraction\n#   https://mathworld.wolfram.com/PeriodicContinuedFraction.html\n\n# A064486 = {1, 2, 2, 2, 2, 4, 2, 36, 38, 244, 244, 1830, 3422, 10626, 3828, 20970, 580384, 4197850, 18395762, 76749396, 166966158, ...}\n# A064025 = {1, 2, 2, 2, 4, 2, 16, 48, 8, 4, 56, 180, 44, 156, 300, 7936, 10388, 11516, 9104, 13469268, 2684084, 2418800, 28468692, 143007944, 85509116, 402570696, ...}\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\nuse ntheory qw(factorial);\n\nsub period_length_mpz {\n    my ($n) = @_;\n\n    $n = Math::GMPz->new(\"$n\");\n\n    return 0 if Math::GMPz::Rmpz_perfect_square_p($n);\n\n    my $t = Math::GMPz::Rmpz_init();\n    my $x = Math::GMPz::Rmpz_init();\n    my $z = Math::GMPz::Rmpz_init_set_ui(1);\n\n    Math::GMPz::Rmpz_sqrt($x, $n);\n\n    my $y = Math::GMPz::Rmpz_init_set($x);\n\n    my $period = 0;\n\n    do {\n        Math::GMPz::Rmpz_add($t, $x, $y);\n        Math::GMPz::Rmpz_div($t, $t, $z);\n        Math::GMPz::Rmpz_mul($t, $t, $z);\n        Math::GMPz::Rmpz_sub($y, $t, $y);\n\n        Math::GMPz::Rmpz_mul($t, $y, $y);\n        Math::GMPz::Rmpz_sub($t, $n, $t);\n        Math::GMPz::Rmpz_divexact($z, $t, $z);\n\n        ++$period;\n\n    } until (Math::GMPz::Rmpz_cmp_ui($z, 1) == 0);\n\n    return $period;\n}\n\nforeach my $n (1..20) {\n    say \"A064025($n) = \", period_length_mpz(factorial($n));\n}\n"
  },
  {
    "path": "Math/period_of_continued_fraction_for_square_roots_ntheory.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 25 January 2019\n# License: GPLv3\n# https://github.com/trizen\n\n# Compute the period length of the continued fraction for square root of a given number.\n\n# Algorithm from:\n#   https://web.math.princeton.edu/mathlab/jr02fall/Periodicity/mariusjp.pdf\n\n# OEIS sequences:\n#   https://oeis.org/A003285 -- Period of continued fraction for square root of n (or 0 if n is a square).\n#   https://oeis.org/A059927 -- Period length of the continued fraction for sqrt(2^(2n+1)).\n#   https://oeis.org/A064932 -- Period length of the continued fraction for sqrt(3^(2n+1)).\n#   https://oeis.org/A067280 -- Terms in continued fraction for sqrt(n), excl. 2nd and higher periods.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Continued_fraction\n#   https://mathworld.wolfram.com/PeriodicContinuedFraction.html\n\n# This program was used in computing the a(15)-a(19) terms of the OEIS sequence A064932.\n#   A064932(15) = 15924930\n#   A064932(16) = 47779238\n#   A064932(17) = 143322850\n#   A064932(18) = 429998586\n#   A064932(19) = 1289970842\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(is_square sqrtint powint divint);\n\nsub period_length {\n    my ($n) = @_;\n\n    my $x = sqrtint($n);\n    my $y = $x;\n    my $z = 1;\n\n    return 0 if is_square($n);\n\n    my $period = 0;\n\n    do {\n        $y = divint(($x + $y),      $z) * $z - $y;\n        $z = divint(($n - $y * $y), $z);\n        ++$period;\n    } until ($z == 1);\n\n    return $period;\n}\n\nfor my $n (1 .. 14) {\n    print \"A064932($n) = \", period_length(powint(3, 2 * $n + 1)), \"\\n\";\n}\n\n__END__\nA064932(1) = 2\nA064932(2) = 10\nA064932(3) = 30\nA064932(4) = 98\nA064932(5) = 270\nA064932(6) = 818\nA064932(7) = 2382\nA064932(8) = 7282\nA064932(9) = 21818\nA064932(10) = 65650\nA064932(11) = 196406\nA064932(12) = 589982\nA064932(13) = 1768938\nA064932(14) = 5309294\n"
  },
  {
    "path": "Math/phi-finder_factorization_method.pl",
    "content": "#!/usr/bin/perl\n\n# A new factorization algorithm for semiprimes, by estimating phi(n).\n\n# The algorithm is called \"Phi-Finder\" and is due to Kyle Kloster (2010), described in his thesis:\n#   Factoring a semiprime n by estimating φ(n)\n\n# See also:\n#   http://gregorybard.com/papers/phi_version_may_7.pdf\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Math::GMPz;\nuse ntheory qw(is_prime is_square sqrtint logint powmod random_nbit_prime);\n\nsub phi_factor($n) {\n\n    return ()   if $n <= 1;\n    return ($n) if is_prime($n);\n\n    if (is_square($n)) {\n        return sqrtint($n);\n    }\n\n    $n = Math::GMPz->new($n);\n\n    my $E  = $n - 2 * sqrtint($n) + 1;\n    my $E0 = Math::GMPz->new(powmod(2, -$E, $n));\n\n    my $L = logint($n, 2);\n    my $i = 0;\n\n    while ($E0 & ($E0 - 1)) {\n        $E0 <<= $L;\n        $E0 %= $n;\n        ++$i;\n    }\n\n    my $t = 0;\n\n    foreach my $k (0 .. $L) {\n        if (powmod(2, $k, $n) == $E0) {\n            $t = $k;\n            last;\n        }\n    }\n\n    my $phi = abs($i * $L - $E - $t);\n\n    my $q = ($n - $phi + 1);\n    my $p = ($q + sqrtint($q * $q - 4 * $n)) >> 1;\n\n    return $p;\n}\n\nforeach my $k (10 .. 30) {\n\n    my $n = Math::GMPz->new(random_nbit_prime($k)) * random_nbit_prime($k);\n    my $p = phi_factor($n);\n\n    say \"$n = \", $p, ' * ', $n / $p;\n}\n"
  },
  {
    "path": "Math/pi_from_infinity.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 15 May 2016\n# Website: https://github.com/trizen\n\n# Generic implementations for infinite sums, infinite\n# products, continued fractions and nested radicals.\n\nuse 5.020;\nuse warnings;\n\nno warnings 'recursion';\nuse experimental qw(signatures);\n\n#\n## Infinite sum\n#\n\nsub sum ($from, $to, $expr) {\n    my $sum = 0;\n    for my $i ($from .. $to) {\n        $sum += $expr->($i);\n    }\n    $sum;\n}\n\nsay \"=> PI from an infinite sum:\";\nsay 4 * sum(0, 100000, sub($n) { (-1)**$n / (2 * $n + 1) });\n\n#\n## Infinite product\n#\n\nsub prod ($from, $to, $expr) {\n    my $prod = 1;\n    for my $i ($from .. $to) {\n        $prod *= $expr->($i);\n    }\n    $prod;\n}\n\nsay \"=> PI from an infinite product:\";\nsay 2 / prod(1, 100000, sub($n) { 1 - 1 / (4 * $n**2) });\n\n#\n## Continued fractions\n#\n\nsub cfrac ($from, $to, $num, $den) {\n    return 0 if ($from > $to);\n    $num->($from) / ($den->($from) + cfrac($from + 1, $to, $num, $den));\n}\n\nsay \"=> PI from a continued fraction:\";\nsay 4 / (1 + cfrac(1, 100000, sub($n) { $n**2 }, sub($n) { 2 * $n + 1 }));\n\n#\n## Nested radicals\n#\n\nsub nestrad ($from, $to, $coeff, $expr) {\n    return 0 if ($from > $to);\n    $expr->($coeff->($from) + nestrad($from + 1, $to, $coeff, $expr));\n}\n\nsay \"=> PI from nested square roots:\";\nsay 2 / prod(\n    1, 100,\n    sub ($n) {\n        nestrad(1, $n, sub($) { 2 }, sub($x) { sqrt($x) }) / 2;\n    }\n);\n\n# A formula by N. J. Wildberger\n# https://www.youtube.com/watch?v=lcIbCZR0HbU\n\nsay sqrt(4**(12+1) *\n    (2 - nestrad(1, 12, sub($) { 2 }, sub($x) { sqrt($x) }))\n);\n"
  },
  {
    "path": "Math/pisano_periods.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 11 October 2017\n# https://github.com/trizen\n\n# Algorithm for computing the Pisano numbers (period of Fibonacci numbers mod n), using the prime factorization of `n`.\n\n# See also:\n#   https://oeis.org/A001175\n#   https://en.wikipedia.org/wiki/Pisano_period\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures lexical_subs);\nuse ntheory qw(addmod factor_exp lcm);\n\nsub pisano_period($mod) {\n\n    my sub find_period($mod) {\n        my ($x, $y) = (0, 1);\n\n        for (my $n = 1 ; ; ++$n) {\n            ($x, $y) = ($y, addmod($x, $y, $mod));\n\n            if ($x == 0 and $y == 1) {\n                return $n;\n            }\n        }\n    }\n\n    my @prime_powers  = map { $_->[0]**$_->[1] } factor_exp($mod);\n    my @power_periods = map { find_period($_) } @prime_powers;\n\n    return lcm(@power_periods);\n}\n\nmy $n      = 5040;\nmy $period = pisano_period($n);\nsay \"Pisano period for modulus $n is $period.\";    #=> 240\n"
  },
  {
    "path": "Math/pisano_periods_efficient_algorithm.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 22 September 2018\n# https://github.com/trizen\n\n# Efficient algorithm for computing the Pisano period: period of Fibonacci\n# numbers mod `n`, assuming that the factorization of `n` can be computed.\n\n# See also:\n#   https://oeis.org/A001175\n#   https://oeis.org/A053031\n#   https://en.wikipedia.org/wiki/Pisano_period\n#   https://en.wikipedia.org/wiki/Wall%E2%80%93Sun%E2%80%93Sun_prime\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse List::Util qw(first);\nuse ntheory qw(divisors factor_exp);\nuse Math::AnyNum qw(:overload kronecker fibmod lcm factorial);\n\nsub pisano_period_pp ($p, $k = 1) {\n    $p**($k - 1) * first { fibmod($_, $p) == 0 } divisors($p - kronecker($p, 5));\n}\n\nsub pisano_period($n) {\n\n    return 0 if ($n <= 0);\n    return 1 if ($n == 1);\n\n    my $d = lcm(map { pisano_period_pp($_->[0], $_->[1]) } factor_exp($n));\n\n    foreach my $k (0 .. 2) {\n        my $t = $d << $k;\n\n        if ((fibmod($t, $n) == 0) and (fibmod($t + 1, $n) == 1)) {\n            return $t;\n        }\n    }\n\n    die \"Conjecture disproved for n=$n\";\n}\n\nsay pisano_period(factorial(10));    #=> 86400\nsay pisano_period(factorial(30));    #=> 204996473853050880000000\nsay pisano_period(2**128 + 1);       #=> 28356863910078205764000346543980814080\n\nsay join(', ', map { pisano_period($_) } 1 .. 20);  #=> 1, 3, 8, 6, 20, 24, 16, 12, 24, 60, 10, 24, 28, 48, 40, 24, 36, 24, 18, 60\n"
  },
  {
    "path": "Math/pocklington-pratt_primality_proving.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 05 January 2020\n# https://github.com/trizen\n\n# Prove the primality of a number, using the Pocklington primality test recursively.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Pocklington_primality_test\n#   https://en.wikipedia.org/wiki/Primality_certificate\n#   https://mathworld.wolfram.com/PrattCertificate.html\n\nuse 5.020;\nuse strict;\nuse warnings;\nuse experimental qw(signatures);\n\nuse List::Util qw(uniq);\nuse ntheory qw(is_prime is_prob_prime primes);\nuse Math::AnyNum qw(:overload isqrt prod is_coprime irand powmod primorial gcd);\nuse Math::Prime::Util::GMP qw(ecm_factor is_strong_pseudoprime);\n\nmy $primorial = primorial(10**6);\n\nsub trial_factor ($n) {\n\n    my @f;\n    my $g = gcd($primorial, $n);\n\n    if ($g > 1) {\n        my @primes = ntheory::factor($g);\n        foreach my $p (@primes) {\n            while ($n % $p == 0) {\n                push @f, $p;\n                $n /= $p;\n            }\n        }\n    }\n\n    return ($n, @f);\n}\n\nsub pocklington_pratt_primality_proving ($n, $lim = 2**64) {\n\n    if ($n <= $lim or $n <= 2) {\n        return is_prime($n);    # fast deterministic test for small n\n    }\n\n    is_prob_prime($n) || return 0;\n\n    if (ref($n) ne 'Math::AnyNum') {\n        $n = Math::AnyNum->new(\"$n\");\n    }\n\n    my $d = $n - 1;\n    my ($B, @f) = trial_factor($d);\n\n    if ($B > 1 and __SUB__->($B, $lim)) {\n        push @f, $B;\n        $B = 1;\n    }\n\n    for (; ;) {\n        my $A = prod(@f);\n\n        if ($A > $B and is_coprime($A, $B)) {\n\n            say \"\\n:: Proving primality of: $n\";\n\n            foreach my $p (uniq(@f)) {\n                for (; ;) {\n                    my $a = irand(2, $d);\n                    is_strong_pseudoprime($n, $a) || return 0;\n                    if (is_coprime(powmod($a, $d / $p, $n) - 1, $n)) {\n                        say \"a = $a ; p = $p\";\n                        last;\n                    }\n                }\n            }\n\n            return 1;\n        }\n\n        my @ecm_factors = map { Math::AnyNum->new($_) } ecm_factor($B);\n\n        foreach my $p (@ecm_factors) {\n            if (__SUB__->($p, $lim)) {\n                while ($B % $p == 0) {\n                    $B /= $p;\n                    $A *= $p;\n                    push @f, $p;\n                }\n            }\n            if ($A > $B) {\n                say \":: Stopping early with A = $A and B = $B\" if ($B > 1);\n                last;\n            }\n        }\n    }\n}\n\nsay \"Is prime: \",\n  pocklington_pratt_primality_proving(115792089237316195423570985008687907853269984665640564039457584007913129603823);\n\n__END__\n:: Proving primality of: 1202684276868524221513588244947\na = 346396580104425418965575454682 ; p = 2\na = 395385292850838170128328828116 ; p = 3\na = 560648981353249253078437405876 ; p = 192697\na = 494703015287234994679974119746 ; p = 5829139\na = 306457770974323789423503072510 ; p = 59483944987587859\n\n:: Proving primality of: 3201964079152361724098258636758155557\na = 1356115518279653627564352210970159943 ; p = 2\na = 2457916028227754146876991447098503864 ; p = 13\na = 11728301593361244989156925656983410 ; p = 51199\na = 2108054294077847671434547666614921115 ; p = 1202684276868524221513588244947\n\n:: Proving primality of: 2848630210554880446022254608450222949126931851754251657020267\na = 1209988187472090611751147313669268320351528758910368461329491 ; p = 2\na = 2300573356420091000839516595493416230415669494600279441813823 ; p = 7\na = 2255070062675661569997567047423251088740948129004746039001652 ; p = 71\na = 1700776819424249129400987278064417150296142232503378309546959 ; p = 397\na = 1557663127914051170819266186415060024746272157947950396848254 ; p = 22483\na = 1529304355972906129963007304614010762285079880618804024992958 ; p = 100274029791527\na = 1359380483007119191612142919174796446436066905484471515166032 ; p = 3201964079152361724098258636758155557\n\n:: Proving primality of: 57896044618658097711785492504343953926634992332820282019728792003956564801911\na = 57400691074692315475639863020768426880305244856451980889960538168345429022524 ; p = 2\na = 25820275722126461008372188295587408543429765560766435733697174460356575227321 ; p = 5\na = 27298126184613458024322898773516636407461062104891054863568660611145831927443 ; p = 19\na = 7100354002561105328600593201175960102344714262592146066784856909856617007329 ; p = 106969315701167\na = 18941027101040193108179225001169566407134428948824247293492332749705988365235 ; p = 2848630210554880446022254608450222949126931851754251657020267\n\n:: Proving primality of: 115792089237316195423570985008687907853269984665640564039457584007913129603823\na = 113522921208063424748606312287587727138037143611024280238876731030118912160215 ; p = 2\na = 2309014289093855479517407977261240733911340029895025970257499692025785552300 ; p = 57896044618658097711785492504343953926634992332820282019728792003956564801911\nIs prime: 1\n"
  },
  {
    "path": "Math/pollard-strassen_factorization_method.pl",
    "content": "#!/usr/bin/perl\n\n# Pollard-Strassen O(n^(1/4)) factorization algorithm.\n\n# Illustrated by David Harvey in the following video:\n#   https://yewtu.be/watch?v=_53s-0ZLxbQ\n\nuse 5.020;\nuse warnings;\n\nuse bigint try => 'GMP';\nuse experimental qw(signatures);\nuse ntheory      qw(random_prime rootint gcd);\n\nuse Math::Polynomial;\nuse Math::ModInt qw(mod);\nuse Math::Polynomial::ModInt;\n\nsub pollard_strassen_factorization ($n, $d = 1 + rootint($n, 4), $tries = $d) {\n\n    my $a = random_prime($n);\n\n    my @baby_steps;\n\n    my $bs = mod(1, $n);\n    foreach my $k (1 .. $d) {\n        push @baby_steps, $bs;\n        $bs *= $a;\n    }\n\n    my $x = Math::Polynomial::ModInt->new(mod(0, $n), mod(1, $n));\n    my @f = map { $x - $_ } @baby_steps;\n\n    # --- Divide-and-Conquer Polynomial Multiplication ---\n    while (@f > 1) {\n        my @next_level;\n\n        # Multiply adjacent pairs in the current level\n        while (@f >= 2) {\n            my $p1 = shift @f;\n            my $p2 = shift @f;\n            push @next_level, $p1->mul($p2);\n        }\n\n        # If there's an odd polynomial left over, promote it to the next level\n        push @next_level, shift @f if @f;\n\n        @f = @next_level;\n    }\n\n    # Extract the final product, or return a constant polynomial of 1 if empty\n    my $f = @f ? $f[0] : Math::Polynomial::ModInt->new(mod(1, $n));\n\n    my $r = mod($a, $n);\n\n    foreach my $k (1 .. $tries) {\n\n        my $b = $r**($k * $d);\n        my $v = $f->evaluate($b)->residue;\n        my $g = gcd($v, $n);\n\n        if ($g > 1 and $g < $n) {\n            return $g;\n        }\n    }\n\n    return 1;\n}\n\nsay pollard_strassen_factorization(1207);\nsay pollard_strassen_factorization(503 * 863);\nsay pollard_strassen_factorization(2**64 + 1, 300, 5 * 300);\n"
  },
  {
    "path": "Math/pollard_p-1_factorization.pl",
    "content": "#!/usr/bin/perl\n\n# Simple implementation of Pollard's p-1 integer factorization algorithm, with the B2 stage.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Pollard%27s_p_%E2%88%92_1_algorithm\n#   https://trizenx.blogspot.com/2019/08/special-purpose-factorization-algorithms.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory      qw(is_prime logint primes prime_iterator sqrtint next_prime);\nuse Math::AnyNum qw(:overload powmod gcd is_coprime mulmod);\n\nsub pollard_pm1_factor ($n, $B1 = logint($n, 6)**3, $B2 = $B1 * logint($B1, 2)) {\n\n    return () if $n <= 1;\n    return $n if is_prime($n);\n    return 2  if $n % 2 == 0;\n\n    my $G = log($B1 * $B1);\n    my $t = 2;\n\n    foreach my $p (@{primes(2, sqrtint($B1))}) {\n        for (1 .. int($G / log($p))) {\n            $t = powmod($t, $p, $n);\n        }\n    }\n\n    my $it = prime_iterator(sqrtint($B1) + 1);\n    for (my $p = $it->() ; $p <= $B1 ; $p = $it->()) {\n        $t = powmod($t, $p, $n);\n        is_coprime($t - 1, $n) || return gcd($t - 1, $n);\n    }\n\n    my @table;\n    my $Q  = next_prime($B1);\n    my $TQ = powmod($t, $Q, $n);\n\n    my $it2 = prime_iterator($Q + 1);\n    for (my $p = $it2->() ; $p <= $B2 ; $p = $it2->()) {\n        $TQ = mulmod($TQ, ($table[$p - $Q] //= powmod($t, $p - $Q, $n)), $n);\n        is_coprime($TQ - 1, $n) || return gcd($TQ - 1, $n);\n        $Q = $p;\n    }\n\n    return gcd($t - 1, $n);\n}\n\nsay pollard_pm1_factor(1204123279);                                #=> 25889\nsay pollard_pm1_factor(83910721266759813859);                      #=> 4545646757\nsay pollard_pm1_factor(406816927495811038353579431);               #=> 9074269\nsay pollard_pm1_factor(38568900844635025971879799293495379321);    #=> 17495058332072672321\n"
  },
  {
    "path": "Math/pollard_rho_exp_factorization.pl",
    "content": "#!/usr/bin/perl\n\n# Pollard's rho integer factorization algorithm.\n\n# This version uses the polynomial:\n#   f(x) = x^e + 2*e - 1\n\n# where e = lcm(1..B), for a small bound B.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Pollard%27s_rho_algorithm\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Math::GMPz;\nuse Math::Prime::Util::GMP qw(consecutive_integer_lcm logint);\n\nsub rho_exp_factor ($n, $max_iter = 5000) {\n\n    my $B = logint($n, 5)**2;\n    my $e = Math::GMPz::Rmpz_init_set_str(consecutive_integer_lcm($B), 10);\n    my $c = 2*$e - 1;\n\n    if (length(\"$n\") <= 12) {\n        $e = Math::GMPz->new(2);\n    }\n\n    my $x = Math::GMPz::Rmpz_init_set_ui(1);\n    my $y = Math::GMPz::Rmpz_init();\n    my $g = Math::GMPz::Rmpz_init();\n\n    Math::GMPz::Rmpz_powm($x, $x, $e, $n);\n    Math::GMPz::Rmpz_add($x, $x, $c);\n    Math::GMPz::Rmpz_mod($x, $x, $n);\n\n    Math::GMPz::Rmpz_powm($y, $x, $e, $n);\n    Math::GMPz::Rmpz_add($y, $y, $c);\n    Math::GMPz::Rmpz_mod($y, $y, $n);\n\n    for (1 .. $max_iter) {\n\n        Math::GMPz::Rmpz_powm($x, $x, $e, $n);\n        Math::GMPz::Rmpz_add($x, $x, $c);\n        Math::GMPz::Rmpz_mod($x, $x, $n);\n\n        Math::GMPz::Rmpz_powm($y, $y, $e, $n);\n        Math::GMPz::Rmpz_add($y, $y, $c);\n        Math::GMPz::Rmpz_mod($y, $y, $n);\n\n        Math::GMPz::Rmpz_powm($y, $y, $e, $n);\n        Math::GMPz::Rmpz_add($y, $y, $c);\n        Math::GMPz::Rmpz_mod($y, $y, $n);\n\n        Math::GMPz::Rmpz_sub($g, $x, $y);\n        Math::GMPz::Rmpz_gcd($g, $g, $n);\n\n        if (Math::GMPz::Rmpz_cmp_ui($g, 1) != 0) {\n            return undef if ($g == $n);\n            return $g;\n        }\n    }\n\n    return $n;\n}\n\nmy @nums = qw(\n    314159265358979323 350011490889402191 2954624367769580651\n    7167393334524676153 10033529742475370477 20135752530477192241\n    21316902507352787201 2559469924891866771047 63469917720180180377579\n  );\n\n@nums = map { Math::GMPz->new($_) } @nums;\n\nforeach my $n (@nums) {\n    say \"rho_exp_factor($n) = \", rho_exp_factor($n);\n}\n\n__END__\nrho_exp_factor(314159265358979323) = 990371647\nrho_exp_factor(350011490889402191) = 692953181\nrho_exp_factor(2954624367769580651) = 490066931\nrho_exp_factor(7167393334524676153) = 4721424559\nrho_exp_factor(10033529742475370477) = 1412164441\nrho_exp_factor(20135752530477192241) = 5907768749\nrho_exp_factor(21316902507352787201) = 3055371353\nrho_exp_factor(2559469924891866771047) = 266349879973\nrho_exp_factor(63469917720180180377579) = 126115748167\n"
  },
  {
    "path": "Math/pollard_rho_factorization.pl",
    "content": "#!/usr/bin/perl\n\n# Simple implementation of Pollard's rho integer factorization algorithm.\n\n# See also:\n#   https://facthacks.cr.yp.to/rho.html\n#   https://en.wikipedia.org/wiki/Pollard%27s_rho_algorithm\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload powmod gcd);\n\nsub rho_factor ($n, $tries = 50000) {\n\n    my sub f($x) {\n        powmod($x, 2, $n) + 1;\n    }\n\n    my $x = f(2);\n    my $y = f($x);\n\n    for (1 .. $tries) {\n\n        $x = f($x);\n        $y = f(f($y));\n\n        my $g = gcd($x - $y, $n);\n\n        $g <= 1  and next;\n        $g >= $n and last;\n\n        return $g;\n    }\n\n    return 1;\n}\n\nsay rho_factor(503 * 863);                   #=> 863\nsay rho_factor(33670570905491953);           #=> 36169843\nsay rho_factor(314159265358979323);          #=> 317213509\nsay rho_factor(242363923520394591022973);    #=> 786757556719\n"
  },
  {
    "path": "Math/polygonal_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 24 September 2017\n# License: GPLv3\n# https://github.com/trizen\n\n# Util functions for working with polygonal numbers.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload);\n\nsub polygonal_number ($n, $k) {\n    $n * ($k * ($n - 1) - 2 * ($n - 2)) / 2;\n}\n\nsub polygonal_root ($n, $k) {\n    (sqrt(8 * ($k - 2) * $n + ($k - 4)**2) + $k - 4) / (2 * ($k - 2));\n}\n\nsub is_polygonal ($n, $k) {\n    polygonal_root($n, $k)->is_int;\n}\n\n#<<<\nsay \"Triangular numbers: \", join(', ', grep { is_polygonal($_, 3) } 1 .. 100);\nsay \"Square numbers:     \", join(', ', grep { is_polygonal($_, 4) } 1 .. 100);\nsay \"Pentagonal numbers: \", join(', ', grep { is_polygonal($_, 5) } 1 .. 100);\nsay \"Hexagonal numbers:  \", join(', ', grep { is_polygonal($_, 6) } 1 .. 100);\nsay \"Heptagonal numbers: \", join(', ', grep { is_polygonal($_, 7) } 1 .. 100);\nsay \"Octagonal numbers:  \", join(', ', grep { is_polygonal($_, 8) } 1 .. 100);\n#>>>\n\nsay '';\n\n#<<<\nsay \"Decagonal numbers: \", join(', ', map { polygonal_number($_, 10) } 1..10);\nsay \"25-gonal numbers:  \", join(', ', map { polygonal_number($_, 25) } 1..10);\nsay \"50-gonal numbers:  \", join(', ', map { polygonal_number($_, 50) } 1..10);\n#>>>\n\n__END__\nTriangular numbers: 1, 3, 6, 10, 15, 21, 28, 36, 45, 55, 66, 78, 91\nSquare numbers:     1, 4, 9, 16, 25, 36, 49, 64, 81, 100\nPentagonal numbers: 1, 5, 12, 22, 35, 51, 70, 92\nHexagonal numbers:  1, 6, 15, 28, 45, 66, 91\nHeptagonal numbers: 1, 7, 18, 34, 55, 81\nOctagonal numbers:  1, 8, 21, 40, 65, 96\n\nDecagonal numbers: 1, 10, 27, 52, 85, 126, 175, 232, 297, 370\n25-gonal numbers:  1, 25, 72, 142, 235, 351, 490, 652, 837, 1045\n50-gonal numbers:  1, 50, 147, 292, 485, 726, 1015, 1352, 1737, 2170\n"
  },
  {
    "path": "Math/polygonal_representations.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 08 March 2018\n# https://github.com/trizen\n\n# Find all the possible polygonal representations P(a,b) for a given number `n`.\n\n# Example:\n#  235 = P(5, 25) = P(235, 2) = P(10, 7)\n\n# See also:\n#   https://oeis.org/A176774\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse ntheory qw(divisors);\nuse Math::AnyNum qw(:overload polygonal);\n\nsub polygonal_representations ($n) {\n\n    my @divisors = divisors(2 * $n);\n\n    shift @divisors;    # skip d=1\n\n    my @representations;\n\n    foreach my $d (@divisors) {\n\n        my $t = $d - 1;\n        my $k = (2*$n / $d + 2*$d - 4);\n\n        if ($k % $t == 0) {\n            push @representations, [$d, $k / $t];\n        }\n    }\n\n    return @representations;\n}\n\nforeach my $i (1 .. 30) {\n\n    my $n = 2**$i + 1;\n    my @P = polygonal_representations($n);\n\n    # Display the solutions\n    say \"2^$i + 1 = \", join(' = ', map { \"P($_->[0], $_->[1])\" } @P);\n\n    # Verify the solutions\n    die 'error' if grep { $_ != $n } map { polygonal($_->[0], $_->[1]) } @P;\n}\n\n__END__\n2^1 + 1 = P(2, 3) = P(3, 2)\n2^2 + 1 = P(2, 5) = P(5, 2)\n2^3 + 1 = P(2, 9) = P(3, 4) = P(9, 2)\n2^4 + 1 = P(2, 17) = P(17, 2)\n2^5 + 1 = P(2, 33) = P(3, 12) = P(33, 2)\n2^6 + 1 = P(2, 65) = P(5, 8) = P(65, 2)\n2^7 + 1 = P(2, 129) = P(3, 44) = P(129, 2)\n2^8 + 1 = P(2, 257) = P(257, 2)\n2^9 + 1 = P(2, 513) = P(3, 172) = P(9, 16) = P(513, 2)\n2^10 + 1 = P(2, 1025) = P(5, 104) = P(1025, 2)\n2^11 + 1 = P(2, 2049) = P(3, 684) = P(2049, 2)\n2^12 + 1 = P(2, 4097) = P(17, 32) = P(4097, 2)\n2^13 + 1 = P(2, 8193) = P(3, 2732) = P(8193, 2)\n2^14 + 1 = P(2, 16385) = P(5, 1640) = P(16385, 2)\n2^15 + 1 = P(2, 32769) = P(3, 10924) = P(9, 912) = P(33, 64) = P(32769, 2)\n2^16 + 1 = P(2, 65537) = P(65537, 2)\n2^17 + 1 = P(2, 131073) = P(3, 43692) = P(131073, 2)\n2^18 + 1 = P(2, 262145) = P(5, 26216) = P(65, 128) = P(262145, 2)\n2^19 + 1 = P(2, 524289) = P(3, 174764) = P(524289, 2)\n2^20 + 1 = P(2, 1048577) = P(17, 7712) = P(1048577, 2)\n2^21 + 1 = P(2, 2097153) = P(3, 699052) = P(9, 58256) = P(129, 256) = P(2097153, 2)\n2^22 + 1 = P(2, 4194305) = P(5, 419432) = P(4194305, 2)\n2^23 + 1 = P(2, 8388609) = P(3, 2796204) = P(8388609, 2)\n2^24 + 1 = P(2, 16777217) = P(257, 512) = P(16777217, 2)\n2^25 + 1 = P(2, 33554433) = P(3, 11184812) = P(33, 63552) = P(33554433, 2)\n2^26 + 1 = P(2, 67108865) = P(5, 6710888) = P(67108865, 2)\n2^27 + 1 = P(2, 134217729) = P(3, 44739244) = P(9, 3728272) = P(513, 1024) = P(134217729, 2)\n2^28 + 1 = P(2, 268435457) = P(17, 1973792) = P(268435457, 2)\n2^29 + 1 = P(2, 536870913) = P(3, 178956972) = P(536870913, 2)\n2^30 + 1 = P(2, 1073741825) = P(5, 107374184) = P(65, 516224) = P(1025, 2048) = P(1073741825, 2)\n"
  },
  {
    "path": "Math/polynomial_interpolation.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 08 December 2018\n# https://github.com/trizen\n\n# Polynomial interpolation:\n#   find the polynomial of lowest possible degree that passes through all the points of a given dataset.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Vandermonde_matrix\n#   https://en.wikipedia.org/wiki/Polynomial_interpolation\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::MatrixLUP;\nuse Math::AnyNum qw(ipow sum);\n\n# A sequence of n numbers\nmy @v = (35, 85, 102, 137, 120);\n\n# Create a new nXn Vandermonde matrix\nmy @A = map {\n    my $n = $_;\n    [map { ipow($n, $_) } 0..$#v];\n} 0..$#v;\n\nmy $A = Math::MatrixLUP->new(\\@A);\nmy $S = $A->solve(\\@v);\n\nsay \"Coefficients: [\", join(', ', @$S), \"]\";\nsay \"Polynomial  : \", join(' + ', map { \"($S->[$_] * x^$_)\" } 0..$#{$S});\nsay \"Terms       : \", join(', ', map { my $x = $_; sum(map { $x**$_ * $S->[$_] } 0..$#{$S}) } 0..$#v);\n\n__END__\nCoefficients: [35, 455/4, -2339/24, 155/4, -121/24]\nPolynomial  : (35 * x^0) + (455/4 * x^1) + (-2339/24 * x^2) + (155/4 * x^3) + (-121/24 * x^4)\nTerms       : 35, 85, 102, 137, 120\n"
  },
  {
    "path": "Math/power_divisors.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 17 August 2021\n# https://github.com/trizen\n\n# Generate all the k-th power divisors of a given number.\n\nuse 5.036;\nuse ntheory qw(:all);\n\nsub power_divisors ($n, $k=1) {\n\n    my @d = (1);\n    my @pp = grep { $_->[1] >= $k } factor_exp($n);\n\n    foreach my $pp (@pp) {\n        my ($p, $e) = @$pp;\n\n        my @t;\n        for (my $i = $k ; $i <= $e ; $i += $k) {\n            my $u = powint($p, $i);\n            push @t, map { mulint($_, $u) } @d;\n        }\n\n        push @d, @t;\n    }\n\n    sort { $a <=> $b } @d;\n}\n\nsay join(', ', power_divisors(3628800, 2));     # square divisors\nsay join(', ', power_divisors(3628800, 3));     # cube divisors\nsay join(', ', power_divisors(3628800, 4));     # 4th power divisors\n"
  },
  {
    "path": "Math/power_of_factorial_ramanujan.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 15 November 2017\n# https://github.com/trizen\n\n# Given a prime `p` and number `n`, the highest power of `p` dividing `n!` equals:\n#   N = Sum_{k>=1} floor(n/p^k)\n\n# In his third notebook, Ramanujan wrote the following inequalities:\n#   n/(p-1) - log(n+1)/log(p) <= N <= (n-1)/(p-1)\n\n# By writing `n` in base `p` (n = Sum_{j=0..m} (b_j * p^j), we can see that:\n#   N = (n - Sum_{j=0..m} b_j) / (p-1)\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(todigits vecsum);\nuse experimental qw(signatures);\n\nsub power_of_factorial_ramanujan ($n, $p) {\n    ($n - vecsum(todigits($n, $p))) / ($p - 1);\n}\n\nsay power_of_factorial_ramanujan(100, 2);    #=> 97\nsay power_of_factorial_ramanujan(100, 3);    #=> 48\n\nsay power_of_factorial_ramanujan(123456, 7);      #=> 20573\nsay power_of_factorial_ramanujan(123456, 127);    #=> 979\n"
  },
  {
    "path": "Math/power_unitary_divisors.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 13 September 2023\n# https://github.com/trizen\n\n# Generate the k-th power unitary divisors of n.\n\n# See also:\n#   https://oeis.org/A056624\n\nuse 5.036;\nuse ntheory qw(:all);\n\nsub power_udivisors ($n, $k = 1) {\n\n    my @d = (1);\n\n    foreach my $pp (factor_exp($n)) {\n        my ($p, $e) = @$pp;\n\n        if ($e % $k == 0) {\n            my $u = powint($p, $e);\n            push @d, map { mulint($_, $u) } @d;\n        }\n    }\n\n    sort { $a <=> $b } @d;\n}\n\nsay join(', ', power_udivisors(3628800, 1));    # unitary divisors\nsay join(', ', power_udivisors(3628800, 2));    # square unitary divisors\nsay join(', ', power_udivisors(3628800, 3));    # cube unitary divisors\nsay join(', ', power_udivisors(3628800, 4));    # 4th power unitary divisors\n\n__END__\n1, 7, 25, 81, 175, 256, 567, 1792, 2025, 6400, 14175, 20736, 44800, 145152, 518400, 3628800\n1, 25, 81, 256, 2025, 6400, 20736, 518400\n1\n1, 81, 256, 20736\n"
  },
  {
    "path": "Math/powerfree_divisors.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 13 September 2023\n# https://github.com/trizen\n\n# Generate the k-powerfree divisors of a given number.\n\n# See also:\n#   https://oeis.org/A048250\n\nuse 5.036;\nuse ntheory qw(:all);\n\nsub powerfree_divisors ($n, $k = 2) {\n\n    my @d = (1);\n\n    foreach my $pp (factor_exp($n)) {\n        my ($p, $e) = @$pp;\n\n        $e = vecmin($e, $k - 1);\n\n        my @t;\n        my $r = 1;\n        for (1 .. $e) {\n            $r = mulint($r, $p);\n            push @t, map { mulint($r, $_) } @d;\n        }\n        push @d, @t;\n    }\n\n    return sort { $a <=> $b } @d;\n}\n\nsay join(', ', powerfree_divisors(5040, 2));    # squarefree divisors\nsay join(', ', powerfree_divisors(5040, 3));    # cubefree divisors\n\n__END__\n1, 2, 3, 5, 6, 7, 10, 14, 15, 21, 30, 35, 42, 70, 105, 210\n1, 2, 3, 4, 5, 6, 7, 9, 10, 12, 14, 15, 18, 20, 21, 28, 30, 35, 36, 42, 45, 60, 63, 70, 84, 90, 105, 126, 140, 180, 210, 252, 315, 420, 630, 1260\n"
  },
  {
    "path": "Math/powers_of_primes_in_factorial.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 25 August 2016\n# Website: https://github.com/trizen\n\n# A simple function that returns the power of a given prime in the factorial of a number.\n\n# For example:\n#\n#   factorial_power(100, 3) = 48\n#\n# because 100! contains 48 factors of 3.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub factorial_power {\n    my ($n, $p) = @_;\n\n    my $count = 0;\n    my $ppow  = $p;\n\n    while ($ppow <= $n) {\n        $count += int($n / $ppow);\n        $ppow *= $p;\n    }\n\n    return $count;\n}\n\nsay factorial_power(100, 3);    #=> 48\n"
  },
  {
    "path": "Math/powers_of_primes_modulus_in_factorial.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 15 September 2016\n# Website: https://github.com/trizen\n\n# Count the number of factors of p modulo p^k in (p^n)! with k <= n.\n\n# Example:\n#           p   n  k\n#   fpower(43, 10, 7) = 6471871693\n#\n# because (43^10)! contains 514559102697244 factors of 43\n# and 514559102697244 mod 43^7 = 6471871693\n\n# See also:\n#   https://projecteuler.net/problem=288\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload powmod);\n\n#\n## Iterative version\n#\nsub fpower {\n    my ($p, $n, $k) = @_;\n\n    return 0 if $n <= 0;\n    $k = $n if $k > $n;\n\n    my $sum = 0;\n    my $mod = $p**$k;\n\n    while ($n > 0) {\n        $sum += powmod($p, --$n, $mod);\n    }\n\n    $sum;\n}\n\n#\n## Recursive version\n#\nsub _fpower_rec {\n    my ($p, $n, $mod) = @_;\n    $n == 0 ? 0 : powmod($p, $n - 1, $mod) + _fpower_rec($p, $n - 1, $mod);\n}\n\nsub fpower_rec {\n    my ($p, $n, $k) = @_;\n\n    return 0 if $n <= 0;\n    $k = $n if $k > $n;\n\n    _fpower_rec($p, $n, $p**$k);\n}\n\nsay fpower(43, 10, 7);\nsay fpower_rec(43, 10, 7);\n"
  },
  {
    "path": "Math/prime_41.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 10 April 2015\n# https://github.com/trizen\n\n# The prime41() function.\n# Inspired from: https://www.youtube.com/watch?v=3K-12i0jclM\n\n# See more about this on: https://en.wikipedia.org/wiki/Formula_for_primes\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(is_prime divisors);\n\n#\n## A general form of: n^2 - n + 41\n#\nsub p41 {\n    my ($x, $y) = @_;\n\n    # $x: Nth number in the sequence\n    # $y: position in the sequence relative to 41\n\n    ## Simple:\n    # $x**2 - $x + 41;\n\n    ## General:\n    $x**2 + (2 * $x * $y) - $x + $y**2 - $y + 41;\n}\n\nforeach my $i (0 .. 100) {\n    my $n = p41($i, 1);\n\n    if (is_prime($n)) {\n        say \"$i. $n - prime\";\n    }\n    else {\n        say \"$i. $n - not prime (factors: \", join(', ', grep { $_ != 1 and $_ != $n } divisors($n)), \")\";\n    }\n}\n\n__END__\n=> Deduced from:\n43^2-2 = 1847 - prime\n44^2-3 = 1933 - prime\n45^2-4 = 2021 - not prime (factors: 43, 47)\n46^2-5 = 2111 - prime\n47^2-6 = 2203 - prime\n48^2-7 = 2297 - prime\n49^2-8 = 2393 - prime\n50^2-9 = 2491 - not prime (factors: 47, 53)\n51^2-10 = 2591 - prime\n52^2-11 = 2693 - prime\n53^2-12 = 2797 - prime\n54^2-13 = 2903 - prime\n55^2-14 = 3011 - prime\n56^2-15 = 3121 - prime\n57^2-16 = 3233 - not prime (factors: 53, 61)\n58^2-17 = 3347 - prime\n59^2-18 = 3463 - prime\n60^2-19 = 3581 - prime\n61^2-20 = 3701 - prime\n62^2-21 = 3823 - prime\n63^2-22 = 3947 - prime\n64^2-23 = 4073 - prime\n65^2-24 = 4201 - prime\n"
  },
  {
    "path": "Math/prime_abundant_sequences.pl",
    "content": "#!/usr/bin/perl\n\n# For a fixed integer base b > 1,\n#   a(n) is the smallest k > a(n-1) such that b^(k-1) == 1 (mod a(n-1)*k), with a(0) = 1.\n\n# Thomas Ordowski's conjecture:\n#   For any integer base b > 1, a(n) is prime for almost all n.\n\n# See also:\n#   https://oeis.org/A306826\n\nuse 5.014;\nuse ntheory qw(:all);\nuse Memoize qw(memoize);\nuse experimental qw(signatures);\n\nmemoize('a');\n\nsub a ($n, $base) {\n\n    return 1 if ($n == 0);\n\n    my $t = a($n - 1, $base);\n    for (my $k = $t + 1 ; ; ++$k) {\n        if (powmod($base, $k - 1, $t * $k) == 1) {\n            return $k;\n        }\n    }\n}\n\nforeach my $base (2 .. 30) {\n\n    my @list;\n    my $k = a(0, $base);\n\n    for (my $n = 0 ; $k < 1e5 ; ++$n) {\n        $k = a($n, $base);\n        push @list, $k;\n    }\n\n    my $prime_count = scalar grep { is_prime($_) } @list;\n    my $total_count = scalar @list;\n\n    printf(\"[%.2f%% primes] b = %2d, a(n) = {%s, ...}\\n\",\n           $prime_count / $total_count * 100,\n           $base, join(', ', @list),\n           \", ...}\");\n}\n\n__END__\n[94.44% primes] b =  2, a(n) = {1, 3, 5, 13, 37, 73, 109, 181, 541, 1621, 4861, 9721, 10531, 17551, 29251, 87751, 526501, 3159001, ...}\n[94.74% primes] b =  3, a(n) = {1, 2, 5, 13, 19, 37, 73, 97, 193, 241, 601, 751, 2251, 3001, 4001, 16001, 96001, 160001, 1120001, ...}\n[92.59% primes] b =  4, a(n) = {1, 3, 5, 7, 13, 19, 37, 73, 91, 97, 193, 241, 277, 461, 691, 1151, 14951, 15641, 70381, 78031, 156061, 312121, 343333, 362407, 724813, 895357, 1044583, ...}\n[93.75% primes] b =  5, a(n) = {1, 2, 3, 7, 13, 17, 97, 193, 577, 1153, 3457, 10369, 28513, 228097, 456193, 5930497, ...}\n[96.00% primes] b =  6, a(n) = {1, 5, 7, 11, 31, 37, 41, 241, 281, 337, 449, 2689, 10753, 12289, 18433, 19457, 58369, 87553, 109441, 127681, 255361, 383041, 478801, 538651, 1077301, ...}\n[92.00% primes] b =  7, a(n) = {1, 2, 3, 5, 13, 25, 29, 43, 61, 181, 193, 241, 1201, 1217, 7297, 12161, 13681, 27361, 54721, 109441, 115201, 172801, 345601, 432001, 2160001, ...}\n[74.19% primes] b =  8, a(n) = {1, 3, 5, 9, 11, 21, 23, 45, 53, 105, 109, 133, 139, 231, 241, 257, 273, 277, 461, 1381, 3221, 5153, 6833, 27329, 40993, 51241, 55511, 222041, 499591, 999181, 1379821, ...}\n[81.82% primes] b =  9, a(n) = {1, 2, 4, 5, 7, 13, 19, 28, 31, 61, 71, 211, 421, 631, 946, 1051, 1471, 2647, 10585, 10627, 11551, 15401, 15841, 15901, 47701, 71551, 157411, 174901, 262351, 524701, 787051, 891991, 1783981, ...}\n[95.65% primes] b = 10, a(n) = {1, 3, 7, 13, 19, 37, 43, 127, 211, 241, 271, 281, 337, 673, 2017, 12097, 20161, 21841, 54601, 81901, 819001, 955501, 4777501, ...}\n[89.47% primes] b = 11, a(n) = {1, 2, 3, 5, 7, 10, 13, 37, 43, 71, 211, 281, 2521, 2633, 5923, 23689, 165817, 497449, 1160713, ...}\n[91.30% primes] b = 12, a(n) = {1, 5, 13, 17, 65, 73, 109, 163, 487, 541, 811, 1297, 1621, 1783, 5347, 26731, 80191, 106921, 187111, 192781, 289171, 867511, 1561519, ...}\n[86.36% primes] b = 13, a(n) = {1, 2, 3, 4, 5, 17, 21, 23, 67, 199, 397, 2377, 7129, 7393, 8009, 8581, 25741, 38611, 115831, 231661, 463321, 1158301, ...}\n[94.74% primes] b = 14, a(n) = {1, 3, 5, 11, 31, 61, 67, 89, 353, 1409, 2113, 6337, 7129, 28513, 64153, 81649, 95257, 238141, 1190701, ...}\n[95.45% primes] b = 15, a(n) = {1, 2, 7, 11, 31, 41, 241, 271, 541, 577, 1153, 3457, 10369, 12097, 72577, 96769, 100801, 102001, 153001, 191251, 212501, 1020001, ...}\n[88.46% primes] b = 16, a(n) = {1, 3, 5, 7, 13, 19, 37, 73, 91, 97, 109, 127, 197, 491, 1471, 5881, 7351, 10501, 21001, 22751, 68251, 68771, 123787, 165049, 174571, 1396561, ...}\n[92.00% primes] b = 17, a(n) = {1, 2, 3, 5, 9, 11, 31, 61, 181, 397, 661, 991, 1123, 1871, 7481, 10099, 11287, 14851, 16633, 55441, 76231, 97021, 145531, 436591, 1018711, ...}\n[82.76% primes] b = 18, a(n) = {1, 5, 13, 17, 19, 23, 67, 133, 139, 277, 829, 1105, 1109, 3325, 3361, 3571, 10711, 12241, 16831, 23563, 43759, 47737, 59671, 70201, 105301, 105319, 351061, 936161, 7957361, ...}\n[91.67% primes] b = 19, a(n) = {1, 2, 3, 5, 7, 13, 37, 73, 109, 181, 193, 577, 673, 2017, 4033, 4177, 5569, 22273, 33409, 41761, 375841, 501121, 534529, 4810753, ...}\n[85.71% primes] b = 20, a(n) = {1, 3, 7, 11, 21, 23, 67, 133, 137, 409, 613, 3061, 3163, 18973, 23189, 27281, 27941, 41911, 125731, 176023, 1408177, ...}\n[90.00% primes] b = 21, a(n) = {1, 2, 5, 11, 13, 17, 29, 85, 89, 221, 229, 457, 761, 1901, 2281, 3041, 4561, 6841, 13681, 14593, 43777, 87553, 94849, 109441, 255361, 319201, 322001, 386401, 418601, 1255801, ...}\n[90.48% primes] b = 22, a(n) = {1, 3, 5, 13, 19, 37, 73, 89, 199, 397, 2377, 7129, 8911, 9109, 18217, 20287, 60859, 243433, 426007, 852013, 2130031, ...}\n[96.15% primes] b = 23, a(n) = {1, 2, 3, 5, 13, 19, 37, 61, 101, 151, 181, 541, 811, 1621, 2161, 6481, 9721, 19441, 58321, 64153, 80191, 240571, 267301, 534601, 588061, 1176121, ...}\n[90.00% primes] b = 24, a(n) = {1, 5, 7, 13, 25, 29, 43, 127, 163, 325, 337, 673, 1009, 1051, 4201, 6301, 10501, 19501, 19801, 25301, 37951, 44851, 45751, 47251, 47701, 95401, 111301, 222601, 296801, 1187201, ...}\n[80.00% primes] b = 25, a(n) = {1, 2, 3, 4, 6, 7, 13, 17, 41, 61, 91, 97, 193, 577, 1153, 1729, 1747, 8731, 10477, 47143, 78571, 104761, 115237, 403327, 1209979, ...}\n[80.95% primes] b = 26, a(n) = {1, 3, 5, 7, 19, 25, 27, 29, 113, 225, 227, 1583, 6329, 63281, 71191, 142381, 355951, 457651, 813601, 915301, 1525501, ...}\n[84.21% primes] b = 27, a(n) = {1, 2, 5, 13, 17, 65, 73, 89, 353, 1409, 9857, 10753, 12545, 12577, 23057, 25153, 54497, 544961, 1634881, ...}\n[90.00% primes] b = 28, a(n) = {1, 3, 5, 9, 11, 31, 61, 101, 401, 601, 1201, 1801, 2161, 6481, 19441, 58321, 59779, 119557, 358669, 2152009, ...}\n[86.96% primes] b = 29, a(n) = {1, 2, 3, 5, 7, 11, 21, 23, 67, 73, 433, 1297, 2593, 5185, 5233, 6977, 20929, 26161, 52321, 117721, 164809, 195329, 1171969, ...}\n[85.71% primes] b = 30, a(n) = {1, 7, 13, 19, 31, 37, 73, 97, 193, 577, 1153, 1537, 1549, 3097, 3169, 4357, 8713, 34849, 47917, 407287, 6109291, ...}\n"
  },
  {
    "path": "Math/prime_count_smooth_sum.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 25 October 2016\n# Website: https://github.com/trizen\n\n# sum(PI(n) - PI(n - sqrt(n)), {n=1, k})\n\n# Interestingly,\n#\n#   PI(n) - PI(n - sqrt(n)) = 0\n#\n# only for n={1, 125, 126}, tested with n <= 10^6.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(prime_count);\n\nmy $limit = shift(@ARGV) || 20;\n\nmy $sum = 0;\nforeach my $n (1 .. $limit) {\n    my $count = prime_count($n) - prime_count(int($n - sqrt($n)));\n    $sum += $count;\n    say $sum;\n}\n\n__END__\n0\n1\n3\n4\n6\n7\n9\n10\n11\n12\n13\n14\n16\n18\n19\n20\n22\n23\n25\n27\n"
  },
  {
    "path": "Math/prime_counting_from_almost_primes.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 27 August 2025\n# https://github.com/trizen\n\n# A sublinear algorithm for computing the Prime Counting function `pi(n)`,\n# based on the number of k-almost primes <= n, for `k >= 2`, which can be computed in sublinear time.\n\n# See also:\n#   https://mathworld.wolfram.com/AlmostPrime.html\n\nuse 5.036;\nuse ntheory qw(:all);\n\nsub k_prime_count ($k, $n) {\n\n    if ($k == 1) {\n        return my_prime_count($n);\n    }\n\n    my $count = 0;\n\n    sub ($m, $p, $k, $j = 0) {\n\n        my $s = rootint(divint($n, $m), $k);\n\n        if ($k == 2) {\n\n            forprimes {\n                $count += my_prime_count(divint($n, mulint($m, $_))) - $j++;\n            } $p, $s;\n\n            return;\n        }\n\n        foreach my $q (@{primes($p, $s)}) {\n            __SUB__->($m * $q, $q, $k - 1, $j++);\n        }\n    }->(1, 2, $k);\n\n    return $count;\n}\n\nsub my_prime_count ($n) {\n\n    state $pi_table = [0, 0, 1, 2, 2];      # a larger lookup table helps a lot!\n\n    if ($n < 0) {\n        return 0;\n    }\n\n    if (defined($pi_table->[$n])) {\n        return $pi_table->[$n];\n    }\n\n    my $M = $n - 1;\n\n    foreach my $k (2 .. logint($n, 2)) {\n        $M -= k_prime_count($k, $n);\n    }\n\n    return ($pi_table->[$n] //= $M);\n}\n\nforeach my $n (1..7) {    # takes ~3 seconds\n    say \"pi(10^$n) = \", my_prime_count(10**$n);\n}\n\n__END__\npi(10^1) = 4\npi(10^2) = 25\npi(10^3) = 168\npi(10^4) = 1229\npi(10^5) = 9592\npi(10^6) = 78498\npi(10^7) = 664579\n"
  },
  {
    "path": "Math/prime_counting_from_squarefree_almost_primes.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 27 August 2025\n# https://github.com/trizen\n\n# A sublinear algorithm for computing the Prime Counting function `pi(n)`,\n# based on the number of squarefree k-almost primes <= n, for `k >= 2`, which can be computed in sublinear time.\n\n# See also:\n#   https://mathworld.wolfram.com/AlmostPrime.html\n\nuse 5.036;\nuse ntheory qw(:all);\n\nsub squarefree_almost_prime_count ($k, $n) {\n\n    if ($k == 0) {\n        return (($n <= 0) ? 0 : 1);\n    }\n\n    if ($k == 1) {\n        return my_prime_count($n);\n    }\n\n    my $count = 0;\n\n    sub ($m, $p, $k, $j = 1) {\n\n        my $s = rootint(divint($n, $m), $k);\n\n        if ($k == 2) {\n\n            forprimes {\n                $count += my_prime_count(divint($n, mulint($m, $_))) - $j++;\n            }\n            $p, $s;\n\n            return;\n        }\n\n        foreach my $q (@{primes($p, $s)}) {\n            __SUB__->(mulint($m, $q), $q + 1, $k - 1, ++$j);\n        }\n      }\n      ->(1, 2, $k);\n\n    return $count;\n}\n\nsub my_prime_count ($n) {\n\n    state %cache = (    # a larger lookup table helps a lot!\n                     0 => 0,\n                     1 => 0,\n                     2 => 1,\n                     3 => 2,\n                     4 => 2,\n                   );\n\n    if ($n < 0) {\n        return 0;\n    }\n\n    if (exists $cache{$n}) {\n        return $cache{$n};\n    }\n\n    my $M = powerfree_count($n, 2) - 1;\n\n    foreach my $k (2 .. exp(LambertW(log($n))) + 1) {\n        $M -= squarefree_almost_prime_count($k, $n);\n    }\n\n    $cache{$n} //= $M;\n}\n\nforeach my $n (1 .. 7) {    # takes ~1 second\n    say \"pi(10^$n) = \", my_prime_count(10**$n);\n}\n\n__END__\npi(10^1) = 4\npi(10^2) = 25\npi(10^3) = 168\npi(10^4) = 1229\npi(10^5) = 9592\npi(10^6) = 78498\npi(10^7) = 664579\n"
  },
  {
    "path": "Math/prime_counting_liouville_formula.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 July 2025\n# https://github.com/trizen\n\n# A sublinear algorithm for computing the Prime Counting function `pi(n)`,\n# based on the Liouville function and the number of k-almost primes <= n, for `k >= 2`.\n\n# See also:\n#   https://mathworld.wolfram.com/AlmostPrime.html\n\nuse 5.036;\nuse ntheory qw(:all);\n\nsub k_prime_count ($k, $n) {\n\n    if ($k == 1) {\n        return my_prime_count($n);\n    }\n\n    my $count = 0;\n\n    sub ($m, $p, $k, $j = 0) {\n\n        my $s = rootint(divint($n, $m), $k);\n\n        if ($k == 2) {\n\n            forprimes {\n                $count += my_prime_count(divint($n, mulint($m, $_))) - $j++;\n            } $p, $s;\n\n            return;\n        }\n\n        foreach my $q (@{primes($p, $s)}) {\n            __SUB__->($m * $q, $q, $k - 1, $j++);\n        }\n    }->(1, 2, $k);\n\n    return $count;\n}\n\nsub my_prime_count ($n) {\n\n    state $pi_table = [0, 0, 1, 2, 2];      # a larger lookup table helps a lot!\n\n    if ($n < 0) {\n        return 0;\n    }\n\n    if (defined($pi_table->[$n])) {\n        return $pi_table->[$n];\n    }\n\n    my $M = sumliouville($n);\n\n    foreach my $k (2 .. logint($n, 2)) {\n        $M -= (-1)**$k * k_prime_count($k, $n);\n    }\n\n    return ($pi_table->[$n] //= 1 - $M);\n}\n\nforeach my $n (1..7) {    # takes ~3 seconds\n    say \"pi(10^$n) = \", my_prime_count(10**$n);\n}\n\n__END__\npi(10^1) = 4\npi(10^2) = 25\npi(10^3) = 168\npi(10^4) = 1229\npi(10^5) = 9592\npi(10^6) = 78498\npi(10^7) = 664579\n"
  },
  {
    "path": "Math/prime_counting_mertens_formula.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 July 2025\n# https://github.com/trizen\n\n# A sublinear algorithm for computing the Prime Counting function `pi(n)`, based on the\n# Mertens function and the number of squarefree k-almost primes <= n, for `k >= 2`.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Mertens_function\n#   https://en.wikipedia.org/wiki/M%C3%B6bius_function\n\nuse 5.036;\nuse ntheory qw(:all);\n\nsub squarefree_almost_prime_count ($k, $n) {\n\n    if ($k == 0) {\n        return (($n <= 0) ? 0 : 1);\n    }\n\n    if ($k == 1) {\n        return my_prime_count($n);\n    }\n\n    my $count = 0;\n\n    sub ($m, $p, $k, $j = 1) {\n\n        my $s = rootint(divint($n, $m), $k);\n\n        if ($k == 2) {\n\n            forprimes {\n                $count += my_prime_count(divint($n, mulint($m, $_))) - $j++;\n            } $p, $s;\n\n            return;\n        }\n\n        foreach my $q (@{primes($p, $s)}) {\n            __SUB__->(mulint($m, $q), $q + 1, $k - 1, ++$j);\n        }\n      }\n      ->(1, 2, $k);\n\n    return $count;\n}\n\nsub my_prime_count ($n) {\n\n    state $pi_table = [0, 0, 1, 2, 2];      # a larger lookup table helps a lot!\n\n    if ($n < 0) {\n        return 0;\n    }\n\n    if (defined($pi_table->[$n])) {\n        return $pi_table->[$n];\n    }\n\n    my $M = mertens($n);\n\n    foreach my $k (2 .. exp(LambertW(log($n))) + 1) {\n        $M -= (-1)**$k * squarefree_almost_prime_count($k, $n);\n    }\n\n    return ($pi_table->[$n] //= 1 - $M);\n}\n\nforeach my $n (1 .. 7) {    # takes ~1 second\n    say \"pi(10^$n) = \", my_prime_count(10**$n);\n}\n\n__END__\npi(10^1) = 4\npi(10^2) = 25\npi(10^3) = 168\npi(10^4) = 1229\npi(10^5) = 9592\npi(10^6) = 78498\npi(10^7) = 664579\n"
  },
  {
    "path": "Math/prime_factorization_concept.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 06 July 2015\n# Website: https://github.com/trizen\n\n# Prime factorization in polynomial time (concept only)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\n#\n## The backwards process of:\n#\n\n#   23 *\n#   17\n#  ----\n#  161\n#  23\n# -----\n#  391\n\n# 23\nmy $x2 = 2;\nmy $x1 = 3;\n\n# 17\nmy $y2 = 1;\nmy $y1 = 7;\n\n# {\n#    1=10*(a*c/10-floor(a*c/10)),\n#    9=10*(b*c/10-floor(b*c/10))+floor(a*c/10)+10*(a*d/10-floor(a*d/10)),\n#    3=floor((b*c+floor(a*c/10))/10)+10*(b*d/10-floor(b*d/10))\n# }\n\n# Last digit\nsay(($x1 * $y1) % 10);\n\n# Middle digit\nsay((($x2 * $y1) % 10) + int($x1 * $y1 / 10) + (($x1 * $y2) % 10));\n\n# First digit\nsay(int((($x2 * $y1) + int($x1 * $y1 / 10)) / 10) + (($x2 * $y2) % 10));\n\n\n#\n## Alternate forms:\n#\n\nsay \"-\" x 80;\n\n# Last digit\nsay(($x1 * $y1 / 10 - int($x1 * $y1 / 10)) * 10);\n\n# Middle digit\nsay(int($x1 * $y1 / 10) - 10 * int($x1 * $y2 / 10) + $x1 * $y2 - 10 * int($x2 * $y1 / 10) + $x2 * $y1);\n\n# First digit\nsay(int($x2 * $y1 / 10 + int($x1 * $y1 / 10) / 10) + 10 * ($x2 * $y2 / 10 - int($x2 * $y2 / 10)));\n"
  },
  {
    "path": "Math/prime_factors_of_binomial_coefficients.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 25 August 2016\n# Website: https://github.com/trizen\n\n# An efficient algorithm for prime factorization of binomial coefficients.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(forprimes todigits vecsum);\n\nsub factorial_power ($n, $p) {\n    ($n - vecsum(todigits($n, $p))) / ($p - 1);\n}\n\n#\n# Example for:\n#     binomial(100, 50)\n#\n# which is equivalent with:\n#    100! / (100-50)! / 50!\n#\n\nmy $n = 100;\nmy $k = 50;\nmy $j = $n - $k;\n\nmy @factors;\n\nforprimes {\n    my $p = factorial_power($n, $_);\n\n    if ($_ <= $k) {\n        $p -= factorial_power($k, $_);\n    }\n\n    if ($_ <= $j) {\n        $p -= factorial_power($j, $_);\n    }\n\n    if ($p > 0) {\n        push @factors, ($_) x $p;\n    }\n} $n;\n\nsay \"Prime factors of binomial($n, $k) = (@factors)\";\n"
  },
  {
    "path": "Math/prime_factors_of_binomial_product.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 16 January 2019\n# https://github.com/trizen\n\n# Efficient formula due to Jeffrey C. Lagarias and Harsh Meht for computing the prime-power factorization of the product of binomials.\n\n# Using the identities:\n#   G(n) = Product_{k=0..n} binomial(n, k) = Product_{k=1..n} k^(2*k - n - 1)\n#                                          = hyperfactorial(n)/superfactorial(n)\n\n# See also:\n#   https://oeis.org/A001142\n#   https://oeis.org/A323444\n\n# Paper:\n#   Jeffrey C. Lagarias, Harsh Mehta\n#   Products of binomial coefficients and unreduced Farey fractions\n#   https://arxiv.org/abs/1409.4145\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nno warnings 'recursion';\n\nuse experimental qw(signatures);\nuse ntheory qw(forprimes todigits vecsum);\n\nmy @cache;\n\nsub sum_of_digits ($n, $p) {\n    return 0 if ($n <= 0);\n    $cache[$n][$p] //= vecsum(todigits($n - 1, $p)) + sum_of_digits($n - 1, $p);\n}\n\nsub power_of_product_of_binomials ($n, $p) {\n    (2 * sum_of_digits($n, $p) - ($n - 1) * vecsum(todigits($n, $p))) / ($p - 1);\n}\n\nsub prime_factorization_of_binomial_product ($n) {\n    my @pp;\n\n    forprimes {\n\n        my $p = $_;\n        my $k = power_of_product_of_binomials($n, $p);\n\n        push @pp, [$p, $k];\n    } $n;\n\n    return @pp;\n}\n\nforeach my $n (2 .. 20) {\n    my @pp = prime_factorization_of_binomial_product($n);\n    printf(\"G(%2d) = %s\\n\", $n, join(' * ', map { sprintf(\"%2d^%-2d\", $_->[0], $_->[1]) } @pp));\n}\n\n__END__\nG( 2) =  2^1\nG( 3) =  2^0  *  3^2\nG( 4) =  2^5  *  3^1\nG( 5) =  2^2  *  3^0  *  5^4\nG( 6) =  2^4  *  3^4  *  5^3\nG( 7) =  2^0  *  3^2  *  5^2  *  7^6\nG( 8) =  2^17 *  3^0  *  5^1  *  7^5\nG( 9) =  2^10 *  3^14 *  5^0  *  7^4\nG(10) =  2^12 *  3^10 *  5^8  *  7^3\nG(11) =  2^4  *  3^6  *  5^6  *  7^2  * 11^10\nG(12) =  2^18 *  3^13 *  5^4  *  7^1  * 11^9\nG(13) =  2^8  *  3^8  *  5^2  *  7^0  * 11^8  * 13^12\nG(14) =  2^11 *  3^3  *  5^0  *  7^12 * 11^7  * 13^11\nG(15) =  2^0  *  3^12 *  5^12 *  7^10 * 11^6  * 13^10\nG(16) =  2^49 *  3^6  *  5^9  *  7^8  * 11^5  * 13^9\nG(17) =  2^34 *  3^0  *  5^6  *  7^6  * 11^4  * 13^8  * 17^16\nG(18) =  2^36 *  3^28 *  5^3  *  7^4  * 11^3  * 13^7  * 17^15\nG(19) =  2^20 *  3^20 *  5^0  *  7^2  * 11^2  * 13^6  * 17^14 * 19^18\nG(20) =  2^42 *  3^12 *  5^16 *  7^0  * 11^1  * 13^5  * 17^13 * 19^17\n"
  },
  {
    "path": "Math/prime_factors_of_factorial.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 18 July 2016\n# https://github.com/trizen\n\n# A shortcut algorithm for finding the factors of n!\n# without computing the factorial in the first place.\n\n# Example:\n#    6! =  2^4  *  3^2  *  5^1\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(forprimes vecsum todigits);\n\nsub factorial_power ($n, $p) {\n    ($n - vecsum(todigits($n, $p))) / ($p - 1);\n}\n\nsub factorial_prime_powers ($n) {\n    my @pp;\n\n    forprimes {\n        push @pp, [$_, factorial_power($n, $_)];\n    } $n;\n\n    return @pp;\n}\n\nfor my $n (2 .. 20) {\n    my @pp = factorial_prime_powers($n);\n    printf(\"%2s! = %s\\n\", $n, join(' * ', map { sprintf(\"%2d^%-2d\", $_->[0], $_->[1]) } @pp));\n}\n\n__END__\n 2! =  2^1\n 3! =  2^1  *  3^1\n 4! =  2^3  *  3^1\n 5! =  2^3  *  3^1  *  5^1\n 6! =  2^4  *  3^2  *  5^1\n 7! =  2^4  *  3^2  *  5^1  *  7^1\n 8! =  2^7  *  3^2  *  5^1  *  7^1\n 9! =  2^7  *  3^4  *  5^1  *  7^1\n10! =  2^8  *  3^4  *  5^2  *  7^1\n11! =  2^8  *  3^4  *  5^2  *  7^1  * 11^1\n12! =  2^10 *  3^5  *  5^2  *  7^1  * 11^1\n13! =  2^10 *  3^5  *  5^2  *  7^1  * 11^1  * 13^1\n14! =  2^11 *  3^5  *  5^2  *  7^2  * 11^1  * 13^1\n15! =  2^11 *  3^6  *  5^3  *  7^2  * 11^1  * 13^1\n16! =  2^15 *  3^6  *  5^3  *  7^2  * 11^1  * 13^1\n17! =  2^15 *  3^6  *  5^3  *  7^2  * 11^1  * 13^1  * 17^1\n18! =  2^16 *  3^8  *  5^3  *  7^2  * 11^1  * 13^1  * 17^1\n19! =  2^16 *  3^8  *  5^3  *  7^2  * 11^1  * 13^1  * 17^1  * 19^1\n20! =  2^18 *  3^8  *  5^4  *  7^2  * 11^1  * 13^1  * 17^1  * 19^1\n"
  },
  {
    "path": "Math/prime_factors_of_superfactorial_and_hyperfactorial.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 16 January 2019\n# https://github.com/trizen\n\n# Efficient formula due to Jeffrey C. Lagarias and Harsh Meht for computing the prime-power factorization of the superfactorial(n) and hyperfactorial(n).\n\n# See also:\n#   https://oeis.org/A001142\n#   https://oeis.org/A323444\n\n# Paper:\n#   Jeffrey C. Lagarias, Harsh Mehta\n#   Products of binomial coefficients and unreduced Farey fractions\n#   https://arxiv.org/abs/1409.4145\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nno warnings 'recursion';\n\nuse experimental qw(signatures);\nuse ntheory qw(todigits vecsum forprimes);\nuse Math::AnyNum qw(superfactorial hyperfactorial prod ipow);\n\nsub factorial_power ($n, $p) {\n    ($n - vecsum(todigits($n, $p))) / ($p - 1);\n}\n\nmy @cache;\n\nsub superfactorial_power ($n, $p) {\n    return 0 if ($n <= 0);\n    $cache[$n][$p] //= superfactorial_power($n - 1, $p) + factorial_power($n, $p);\n}\n\nsub hyperfactorial_power ($n, $p) {\n    $n * factorial_power($n, $p) - superfactorial_power($n - 1, $p);\n}\n\nsub prime_factorization_of_superfactorial ($n) {\n    my @pp;\n\n    forprimes {\n\n        my $p = $_;\n        my $k = superfactorial_power($n, $p);\n\n        push @pp, [$p, $k];\n    }\n    $n;\n\n    return @pp;\n}\n\nsub prime_factorization_of_hyperfactorial ($n) {\n    my @pp;\n\n    forprimes {\n\n        my $p = $_;\n        my $k = hyperfactorial_power($n, $p);\n\n        push @pp, [$p, $k];\n    }\n    $n;\n\n    return @pp;\n}\n\nforeach my $n (2 .. 15) {\n\n    my @S_pp = prime_factorization_of_superfactorial($n);\n    my @H_pp = prime_factorization_of_hyperfactorial($n);\n\n    printf(\"S(%2d) = %s\\n\", $n, join(' * ', map { sprintf(\"%2d^%-2d\", $_->[0], $_->[1]) } @S_pp));\n    printf(\"H(%2d) = %s\\n\", $n, join(' * ', map { sprintf(\"%2d^%-2d\", $_->[0], $_->[1]) } @H_pp));\n\n    prod(map { ipow($_->[0], $_->[1]) } @S_pp) == superfactorial($n) or die \"S($n) error\";\n    prod(map { ipow($_->[0], $_->[1]) } @H_pp) == hyperfactorial($n) or die \"H($n) error\";\n}\n\n__END__\nS( 2) =  2^1\nH( 2) =  2^2\nS( 3) =  2^2  *  3^1\nH( 3) =  2^2  *  3^3\nS( 4) =  2^5  *  3^2\nH( 4) =  2^10 *  3^3\nS( 5) =  2^8  *  3^3  *  5^1\nH( 5) =  2^10 *  3^3  *  5^5\nS( 6) =  2^12 *  3^5  *  5^2\nH( 6) =  2^16 *  3^9  *  5^5\nS( 7) =  2^16 *  3^7  *  5^3  *  7^1\nH( 7) =  2^16 *  3^9  *  5^5  *  7^7\nS( 8) =  2^23 *  3^9  *  5^4  *  7^2\nH( 8) =  2^40 *  3^9  *  5^5  *  7^7\nS( 9) =  2^30 *  3^13 *  5^5  *  7^3\nH( 9) =  2^40 *  3^27 *  5^5  *  7^7\nS(10) =  2^38 *  3^17 *  5^7  *  7^4\nH(10) =  2^50 *  3^27 *  5^15 *  7^7\nS(11) =  2^46 *  3^21 *  5^9  *  7^5  * 11^1\nH(11) =  2^50 *  3^27 *  5^15 *  7^7  * 11^11\nS(12) =  2^56 *  3^26 *  5^11 *  7^6  * 11^2\nH(12) =  2^74 *  3^39 *  5^15 *  7^7  * 11^11\nS(13) =  2^66 *  3^31 *  5^13 *  7^7  * 11^3  * 13^1\nH(13) =  2^74 *  3^39 *  5^15 *  7^7  * 11^11 * 13^13\nS(14) =  2^77 *  3^36 *  5^15 *  7^9  * 11^4  * 13^2\nH(14) =  2^88 *  3^39 *  5^15 *  7^21 * 11^11 * 13^13\nS(15) =  2^88 *  3^42 *  5^18 *  7^11 * 11^5  * 13^3\nH(15) =  2^88 *  3^54 *  5^30 *  7^21 * 11^11 * 13^13\n"
  },
  {
    "path": "Math/prime_formulas.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 03 July 2015\n# Website: https://github.com/trizen\n\n# Generate a top list of prime formulas (in the form of: n^2 - n ± m)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(is_prime);\n\nmy %top;\nmy $n_limit = 1e4;\nmy $m_limit = 1e2;\n\nfor (my $m = 1 ; $m <= $m_limit ; $m += 2) {\n    foreach my $n (0 .. $n_limit) {\n        is_prime($n**2 - $n + $m)      && ++$top{$m};\n        is_prime(abs($n**2 - $n - $m)) && ++$top{-$m};\n    }\n}\n\nforeach my $key (sort { $top{$b} <=> $top{$a} } keys %top) {\n    printf(\"[%5d] n^2 - n %s %s\\n\", $top{$key}, $key > 0 ? ('+', $key) : ('-', abs($key)));\n}\n"
  },
  {
    "path": "Math/prime_functions_in_terms_of_zeros_of_zeta.pl",
    "content": "#!/usr/bin/perl\n\n# Approximate the Chebyshev function and the weighted prime counting function, using zeros of the Riemann zeta function.\n\n# See also:\n#   https://oeis.org/A267712\n#   https://en.wikipedia.org/wiki/Chebyshev_function\n#   https://en.wikipedia.org/wiki/Logarithmic_integral_function\n#   https://en.wikipedia.org/wiki/Riemann_zeta_function\n\nuse utf8;\nuse 5.020;\nuse strict;\nuse warnings;\n\nbinmode(STDOUT, ':utf8');\n\nuse ntheory qw(forprimes prime_count);\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload gamma complex tau ilog iroot log Li harmreal);\n\nmy @zeta_ρ = map { chomp; complex(1 / 2, $_) } <DATA>;\n\nsub Li_approx ($x) {\n\n    my $sum = 0;\n    foreach my $k (0 .. 0) {\n        $sum += gamma($k + 1) / log($x)**$k;\n    }\n\n    return ($sum * ($x / log($x)));\n}\n\nsub chebyshev_ψ ($x) {\n\n    my $sum = 0;\n    forprimes {\n        $sum += ilog($x, $_) * log($_)\n    } $x;\n\n    return $sum;\n}\n\nsub weighted_prime_count ($x) {\n    my $sum = 0;\n\n    foreach my $k (1 .. ilog($x, 2)) {\n        $sum += Math::AnyNum->new(prime_count(iroot($x, $k))) / $k;\n    }\n\n    return $sum;\n}\n\nsub weighted_prime_count_from_zeta_zeros ($x) {\n    my $sum = Li($x);\n\n    foreach my $ρ (@zeta_ρ) {\n        $sum -= Li_approx($x**$ρ);\n    }\n\n    return abs($sum - log(2));\n}\n\nsub chebyshev_ψ_from_zeta_zeros($x) {\n    my $sum = $x - log(tau) - log(1 - $x**(-2)) / 2;\n\n    foreach my $ρ (@zeta_ρ) {\n        $sum -= $x**$ρ / $ρ;\n    }\n\n    return abs($sum);\n}\n\nmy $x = 10**3;\n\nsay \"ψ($x) = \", chebyshev_ψ($x);                    # 996.680912247175240263021765666421541665778436902\nsay \"ψ($x) ≅ \", chebyshev_ψ_from_zeta_zeros($x);    # 996.068434632130345546023799228964726756917555651\n\nsay \"\\n=> Weighted prime count approximation: \";\nforeach my $k (10 .. 14) {\n    my $exact  = weighted_prime_count(10**$k);\n    my $approx = weighted_prime_count_from_zeta_zeros(10**$k);\n    say \"Π(10^$k) = \", $exact->as_dec, \" ≅ \", $approx, ' -> ', abs($exact - $approx);\n}\n\n__DATA__\n14.1347251417346937904572519835624702707842571157\n21.0220396387715549926284795938969027773343405249\n25.0108575801456887632137909925628218186595496726\n30.4248761258595132103118975305840913201815600237\n32.9350615877391896906623689640749034888127156035\n37.5861781588256712572177634807053328214055973508\n40.9187190121474951873981269146332543957261659628\n43.3270732809149995194961221654068057826456683718\n48.0051508811671597279424727494275160416868440011\n49.7738324776723021819167846785637240577231782997\n52.9703214777144606441472966088809900638250178888\n56.4462476970633948043677594767061275527822644717\n59.3470440026023530796536486749922190310987728065\n60.8317785246098098442599018245240038029100904512\n65.1125440480816066608750542531837050293481492952\n67.0798105294941737144788288965222167701071449517\n69.5464017111739792529268575265547384430124742096\n72.0671576744819075825221079698261683904809066215\n75.7046906990839331683269167620303459228119035307\n77.1448400688748053726826648563046370157960324492\n79.3373750202493679227635928771162281906132467431\n82.9103808540860301831648374947706094975088805938\n84.7354929805170501057353112068277414171066279342\n87.4252746131252294065316678509192132521718864013\n88.8091112076344654236823480795093783954448934098\n92.4918992705584842962597252418106848787217940277\n94.6513440405198869665979258152081539377280270157\n95.870634228245309758741029219246781695256461225\n98.8311942181936922333244201386223278206580390634\n101.317851005731391228785447940292308906332866384\n103.725538040478339416398408108695280834481173069\n105.446623052326094493670832414111808997282753929\n107.168611184276407515123351963086191213476707881\n111.02953554316967452465645030994435041534596839\n111.874659176992637085612078716770594960311749873\n114.320220915452712765890937276191079809917657724\n116.226680320857554382160804312064755127329851232\n118.790782865976217322979139702699824347306210593\n121.370125002420645918945532970499922723001310632\n122.946829293552588200817460330770016496214389874\n124.256818554345767184732007966129924441573538775\n127.516683879596495124279323766906076268088309882\n129.578704199956050985768033906179973608640953265\n131.087688530932656723566372461501349059203547503\n133.497737202997586450130492042640607664974174944\n134.756509753373871331326064157169736178396068614\n138.116042054533443200191555190282447859835274624\n139.736208952121388950450046523382460846790052565\n141.12370740402112376194035381847535509030066088\n143.11184580762063273940512386891392996623310243\n146.000982486765518547402507596424682428975741233\n147.42276534255960204952118501043150616877277525\n150.05352042078488035143246723695937062303732156\n150.925257612241466761852524678305627602426770473\n153.024693811198896198256544255185446508590434904\n156.112909294237867569750189310169194746535308501\n157.597591817594059887530503158498765730723899519\n158.849988171420498724174994775540271414335083049\n161.188964137596027519437344129369554364915790327\n163.030709687181987243311039000687994896964461416\n165.537069187900418830038919354874797328367251745\n167.184439978174513440957756246210378736460769243\n169.09451541556882148950587118143183479666764858\n169.911976479411698966699843595821792288394437125\n173.411536519591552959846118649345595254156066063\n174.754191523365725813378762455866917938755717621\n176.441434297710418888892641057860933528118497109\n178.377407776099977285830935414184426183132361461\n179.916484020256996139340036612051237453687607553\n182.207078484366461915407037226987798690797457778\n184.874467848387508800960646617234258413351022912\n185.59878367770747146652770426839264661293471765\n187.228922583501851991641540586131243016810734604\n189.416158656016937084852289099845324491357103023\n192.026656360713786547283631425583430105839920298\n193.079726603845704047402205794376054604020615811\n195.265396679529235321463187814862250926905052452\n196.876481840958316948622263914696207735746028692\n198.015309676251912424919918702208867155062695439\n201.264751943703788733016133427548173222402863639\n202.493594514140534277686660637864315821020244899\n204.189671803104554330716438386313685136534529229\n205.394697202163286025212379390693090923722914772\n207.906258887806209861501967907753644268659403769\n209.576509716856259852835644289886752175390783181\n211.690862595365307563907486730719294253394030983\n213.347919359712666190639122021072608821897183277\n214.547044783491423222944201072590691045599888053\n216.169538508263700265869563354498128575453714274\n219.067596349021378985677256590437241245149182927\n220.714918839314003369115592633906339656761145078\n221.430705554693338732097475119276077950222331077\n224.00700025460433521172887552850489535608598995\n224.983324669582287503782523680528656772090054486\n227.421444279679291310461436160659639963969148322\n229.337413305525348107760083306055740082752341388\n231.250188700499164773806186770010372606708495843\n231.987235253180248603771668539197862205419833995\n233.693404178908300640704494732569788179537227755\n236.524229665816205802475507955662978689529495212\n"
  },
  {
    "path": "Math/prime_numbers_generator.pl",
    "content": "#!/usr/bin/perl\n\nuse 5.014;\n\nOUTER: for (my $i = 3 ; ; $i += 2) {\n    foreach my $j (2 .. sqrt($i)) {\n        $i % $j || next OUTER;\n    }\n    say $i;\n}\n"
  },
  {
    "path": "Math/prime_omega_function_generalized.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 25 November 2018\n# https://github.com/trizen\n\n# Generalization of the prime omega functions `ω_m(n)` and `Ω_m(n)`, for `m>=0`:\n#\n#     ω_m(n) = n^m * Sum_{p|n} 1/p^m\n#\n# and:\n#\n#     Ω_m(n) = Sum_{p^k|n} Sum_{j=1..k} n^m / p^(j*m)\n#            = Sum_{p^k|n} n^m * (p^(m*k) - 1) / (p^m - 1) / p^(m*k)\n#\n\n# Where we have the following identities:\n#   ω(n) = ω_0(n)\n#   Ω(n) = Ω_0(n)\n\n# See also:\n#   https://oeis.org/A069359\n#   https://oeis.org/A322068\n#   https://en.wikipedia.org/wiki/Prime_omega_function\n#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(factor_exp vecsum);\n\nsub omega ($n, $m) {\n    vecsum(map { $n**$m / $_->[0]**$m } factor_exp($n));\n}\n\nsub bigomega ($n, $m) {\n    vecsum(\n        map {\n            my $p = $_;\n            vecsum(map { $n**$m / $p->[0]**($_ * $m) } 1 .. $p->[1])\n        } factor_exp($n)\n    );\n}\n\nforeach my $k (0 .. 5) {\n    say \"ω_$k(n) = [\", join(', ', map { omega($_, $k) } 1 .. 25), \"]\";\n    say \"Ω_$k(n) = [\", join(', ', map { bigomega($_, $k) } 1 .. 25), \"]\\n\";\n}\n\n__END__\nω_0(n) = [0, 1, 1, 1, 1, 2, 1, 1, 1, 2, 1, 2, 1, 2, 2, 1, 1, 2, 1, 2, 2, 2, 1, 2, 1]\nΩ_0(n) = [0, 1, 1, 2, 1, 2, 1, 3, 2, 2, 1, 3, 1, 2, 2, 4, 1, 3, 1, 3, 2, 2, 1, 4, 2]\n\nω_1(n) = [0, 1, 1, 2, 1, 5, 1, 4, 3, 7, 1, 10, 1, 9, 8, 8, 1, 15, 1, 14, 10, 13, 1, 20, 5]\nΩ_1(n) = [0, 1, 1, 3, 1, 5, 1, 7, 4, 7, 1, 13, 1, 9, 8, 15, 1, 17, 1, 19, 10, 13, 1, 29, 6]\n\nω_2(n) = [0, 1, 1, 4, 1, 13, 1, 16, 9, 29, 1, 52, 1, 53, 34, 64, 1, 117, 1, 116, 58, 125, 1, 208, 25]\nΩ_2(n) = [0, 1, 1, 5, 1, 13, 1, 21, 10, 29, 1, 61, 1, 53, 34, 85, 1, 121, 1, 141, 58, 125, 1, 253, 26]\n\nω_3(n) = [0, 1, 1, 8, 1, 35, 1, 64, 27, 133, 1, 280, 1, 351, 152, 512, 1, 945, 1, 1064, 370, 1339, 1, 2240, 125]\nΩ_3(n) = [0, 1, 1, 9, 1, 35, 1, 73, 28, 133, 1, 307, 1, 351, 152, 585, 1, 953, 1, 1189, 370, 1339, 1, 2483, 126]\n\nω_4(n) = [0, 1, 1, 16, 1, 97, 1, 256, 81, 641, 1, 1552, 1, 2417, 706, 4096, 1, 7857, 1, 10256, 2482, 14657, 1, 24832, 625]\nΩ_4(n) = [0, 1, 1, 17, 1, 97, 1, 273, 82, 641, 1, 1633, 1, 2417, 706, 4369, 1, 7873, 1, 10881, 2482, 14657, 1, 26209, 626]\n\nω_5(n) = [0, 1, 1, 32, 1, 275, 1, 1024, 243, 3157, 1, 8800, 1, 16839, 3368, 32768, 1, 66825, 1, 101024, 17050, 161083, 1, 281600, 3125]\nΩ_5(n) = [0, 1, 1, 33, 1, 275, 1, 1057, 244, 3157, 1, 9043, 1, 16839, 3368, 33825, 1, 66857, 1, 104149, 17050, 161083, 1, 289619, 3126]\n"
  },
  {
    "path": "Math/prime_quadratic_polynomial_analyzer.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 12 April 2015\n# https://github.com/trizen\n\n# Analyze the number of primes generated by each quadratic polynomial formula\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(is_prime);\n\nmy @formulas = (\n                sub { $_[0]**2 - $_[0] + 41 },\n                sub { $_[0]**2 - $_[0] + 111 },\n                sub { $_[0]**2 - $_[0] + 285 },\n                sub { $_[0]**2 - $_[0] + 171 },\n                sub { $_[0]**2 - $_[0] + 107 },\n                sub { $_[0]**2 - $_[0] + 101 },\n                sub { $_[0]**2 - $_[0] + 75 },\n                sub { $_[0]**2 - $_[0] + 315 },\n                sub { $_[0]**2 - $_[0] + 227 },\n                sub { $_[0]**2 - $_[0] + 621 },\n               );\n\nmy %top;\nmy $n = shift(@ARGV) // 100000;\n\nforeach my $i (0 .. $#formulas) {\n    foreach my $j (1 .. $n) {\n        ++$top{$i} if is_prime($formulas[$i]->($j));\n    }\n}\n\nforeach my $key (sort { $top{$b} <=> $top{$a} } keys %top) {\n    my $y = $formulas[$key]->(0);\n    my $f = sprintf(\"n^2 - n + %3d\", $y);\n    printf \"%13s: %56d (%5.2f%%)\\n\", $f, $top{$key}, $top{$key} / $n * 100;\n}\n\n__END__\n# For n={1,100000}:\nn^2 - n +  41:                                                    31985 (31.99%)\nn^2 - n + 107:                                                    25162 (25.16%)\nn^2 - n + 227:                                                    24658 (24.66%)\nn^2 - n + 101:                                                    24549 (24.55%)\nn^2 - n + 171:                                                     8647 ( 8.65%)\nn^2 - n + 111:                                                     6838 ( 6.84%)\nn^2 - n + 621:                                                     3738 ( 3.74%)\nn^2 - n + 315:                                                     3305 ( 3.31%)\nn^2 - n + 285:                                                     2992 ( 2.99%)\nn^2 - n +  75:                                                     2933 ( 2.93%)\n"
  },
  {
    "path": "Math/prime_quadratic_polynomials.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 12 April 2015\n# https://github.com/trizen\n\n# A program that finds quadratic polynomials which will generate primes (with some gaps)\n# -- algorithm complexity: O(n) --\n\n# See also: https://en.wikipedia.org/wiki/Formula_for_primes\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(is_prime);\n\nmy $i = 1;\nmy $j = 1;\n\nmy $n = shift(@ARGV) // 8000000;    # duration: about 7 seconds\nmy $limit = int(sqrt($n)) - 1;\n\nmy %top;                          # store some info about primes\nmy $top = 10;                     # how many formulas to display at the end\n\nfor my $m (reverse(0 .. $limit)) {\n    my $pos = $m;\n    for my $n ($j .. $i**2) {\n        $top{$pos}{height} //= $i;\n        $top{$pos}{count}  //= 0;\n        if (is_prime($j)) {\n            $top{$pos}{count}++;\n            $top{$pos}{first} //= $j;\n        }\n        ++$pos;\n        ++$j;\n    }\n    ++$i;\n}\n\nmy $counter = 0;\nforeach my $i (sort { $top{$b}{count} <=> $top{$a}{count} } keys %top) {\n    say(\n        \"height: \"            => $top{$i}{height},\n        \"; count: \"           => $top{$i}{count},\n        \"; first: \"           => $top{$i}{first},\n        \"\\nf(n) = n^2 + n + \" => $top{$i}{height},\n        \"\\ng(n) = n^2 + \"     => ($top{$i}{height} * 2 + 1) . 'n + ' . (($top{$i}{height} + 1)**2 - 1),\n        \"\\n\"\n       );\n    last if ++$counter == $top;\n}\n"
  },
  {
    "path": "Math/prime_signature_numbers_in_range.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 22 April 2026\n# https://github.com/trizen\n\n# Generate all the k-omega numbers in range [A,B] that have a given prime signature.\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\n\nsub rootint_ceil($n, $k) {\n    return rootint($n, $k) + (is_power($n, $k) ? 0 : 1);\n}\n\nsub prime_signature_numbers_in_range($A, $B, $prime_signature) {\n\n    my @list;\n    my $k = scalar(@$prime_signature);\n\n    if ($k == 0) {\n        push(@list, 1) if ($A <= 1 and 1 <= $B);\n        return @list;\n    }\n\n    # The smallest possible number with k distinct prime factors\n    $A = vecmax(pn_primorial($k), $A);\n\n    my $generate = sub ($m, $lo, $k, $P, $sum_e) {\n\n        my $e = $P->[$k - 1];\n        my $hi = rootint(divint($B, $m), $sum_e);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        # Base case\n        if ($k == 1) {\n\n            # Tighten the lower bound based on A\n            my $lo_tight = vecmax($lo, rootint_ceil(cdivint($A, $m), $e));\n\n            foreach my $p (@{primes($lo_tight, $hi)}) {\n                push @list, mulint($m, powint($p, $e));\n            }\n\n            return;\n        }\n\n        for (my $p = $lo; $p <= $hi; ) {\n            my $t = mulint($m, powint($p, $e));\n            my $r = next_prime($p);\n            __SUB__->($t, $r, $k - 1, $P, $sum_e - $e);\n            $p = $r;\n        }\n    };\n\n    my %seen;\n    my $sum_e = vecsum(@$prime_signature);\n\n    if ($sum_e > logint($B, 2)) {\n        return;\n    }\n\n    forperm {\n        my @perm = @{$prime_signature}[@_];\n        if (!$seen{join(' ', @perm)}++) {\n            $generate->(1, 2, scalar(@perm), \\@perm, $sum_e);\n        }\n    } $k;\n\n    return sort { $a <=> $b } @list;\n}\n\n# Example\nmy $prime_signature = [3, 2, 2];\nmy $A               = 2000;\nmy $B               = 10000;\n\nmy @arr = prime_signature_numbers_in_range($A, $B, $prime_signature);\nsay \"Generated: @arr\";\n\nmy @bf = grep {\n    join(' ', prime_signature($_)) eq join(' ', sort { $b <=> $a } @$prime_signature)\n} vecmax(pn_primorial(scalar(@$prime_signature)), $A) .. $B;\n\n\"@arr\" eq \"@bf\" or die \"Mismatch detected!\";\n"
  },
  {
    "path": "Math/prime_summation.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 28 October 2015\n# Website: https://github.com/trizen\n\n# Count how many times an even number can be written as the sum of two or more sub-primes\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nno warnings 'recursion';\n\nuse ntheory qw(primes);\nuse Memoize qw(memoize);\n\nmy $limit = 1000;\nmy $primes = primes(0, $limit);\n\nmy %primes;\n@primes{@{$primes}} = ();\n\nsub sum_prime {\n    my ($n) = @_;\n\n    my $sum = 0;\n    foreach my $prime (@{$primes}) {\n        last if ($prime > ($n / 2));\n        my $diff = $n - $prime;\n        if (exists $primes{$diff}) {\n            $sum += 1 + sum_prime($diff);\n        }\n    }\n\n    $sum;\n}\n\nmemoize('sum_prime');     # cache the function to improve performance\n\nfor (my $i = 2 ; $i <= $limit ; $i += 2) {\n    say \"$i\\t\", sum_prime($i);\n}\n"
  },
  {
    "path": "Math/prime_zeta.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 16 November 2015\n# Website: https://github.com/trizen\n\n# zeta(s) = sum(1 / k^s)                        from k=1 to Infinity\n# zeta(s) = product(1 / (1 - prime(k)^(-s)))    from k=1 to Infinity\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(nth_prime);\n\nsub prime_zeta {\n    my ($s) = @_;\n\n    my $p = 1;\n    for my $i (1 .. 10000) {\n        $p *= 1 / (1 - 1 / nth_prime($i)**$s);\n    }\n    return $p;\n}\n\nsay sqrt(prime_zeta(2) * 6);\n"
  },
  {
    "path": "Math/primes_diff.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# License: GPLv3\n# Date: 20th November 2013\n# https://trizenx.blogspot.com\n\n# Prime numbers with difference of two\n# are grouped together if have a given difference\n# related to other numbers.\n\n# Example: 17, 19 and 59, 61 (diff == 42)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Data::Dump qw(pp);\nuse ntheory qw(is_prime);\n\nmy @primes = grep { is_prime($_) } 0 .. 1000;\n\nmy @twin_primes;\nforeach my $i (0 .. $#primes) {\n    foreach my $j ($i + 1 .. $#primes) {\n        my $diff = $primes[$j] - $primes[$i];\n        if ($diff == 2) {\n            push @twin_primes, [$primes[$i], $primes[$j]];\n        }\n        elsif ($diff > 2) {\n            last;\n        }\n    }\n}\n\nmy %table;\nforeach my $i (0 .. $#twin_primes) {\n    foreach my $j ($i + 1 .. $#twin_primes) {\n        my $diff = $twin_primes[$j][0] - $twin_primes[$i][0];\n        push @{$table{$diff}}, [[@{$twin_primes[$i]}], [@{$twin_primes[$j]}]];\n    }\n}\n\nmy @max = (sort { $#{$table{$b}} <=> $#{$table{$a}} } keys %table);\n\n# Top 10\nforeach my $i (0 .. 9) {\n    say \"$max[$i]: \", pp($table{$max[$i]});\n}\n"
  },
  {
    "path": "Math/primes_sum_of_pair_product.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 07 April 2016\n# Website: https://github.com/trizen\n\n# Sum of product of pair of primes that differ by a given constant.\n#   ∞\n#  ---\n#  \\     1     1\n#  /    --- * ---\n#  ---   p    p+c\n#  p\n#  p+c\n\nuse 5.010;\nuse strict;\n\nuse ntheory qw(is_prime forprimes);\n\nmy $C = 2;      # 2 is for twin primes\nmy $j = 0;\nmy $S = 0.0;\n\nforprimes {\n    is_prime($j = $_ + $C) && (\n        $S += 1 / ($_ * $j)\n    );\n} 1, 1000000000;\n\nsay $S;\n"
  },
  {
    "path": "Math/primitive_sum_of_two_squares.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 24 October 2017\n# https://github.com/trizen\n\n# Find a solution to x^2 + y^2 = n, for numbers `n` whose prime divisors are\n# all congruent to 1 mod 4, with the exception of at most a single factor of 2.\n\n# Blog post:\n#   https://trizenx.blogspot.com/2017/10/representing-integers-as-sum-of-two.html\n\n# See also:\n#   https://oeis.org/A008784\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(sqrtmod);\nuse experimental qw(signatures);\n\nsub primitive_sum_of_two_squares ($p) {\n\n    if ($p == 2) {\n        return (1, 1);\n    }\n\n    my $s = sqrtmod($p - 1, $p) || return;\n    my $q = $p;\n\n    while ($s * $s > $p) {\n        ($s, $q) = ($q % $s, $s);\n    }\n\n    return ($s, $q % $s);\n}\n\nforeach my $n (1 .. 100) {\n    my ($x, $y) = primitive_sum_of_two_squares($n);\n\n    if (defined($x) and defined($y)) {\n        say \"f($n) = $x^2 + $y^2\";\n\n        if ($n != $x**2 + $y**2) {\n            die \"error for $n\";\n        }\n    }\n}\n\n__END__\nf(2) = 1^2 + 1^2\nf(5) = 2^2 + 1^2\nf(10) = 3^2 + 1^2\nf(13) = 3^2 + 2^2\nf(17) = 4^2 + 1^2\nf(25) = 4^2 + 3^2\nf(26) = 5^2 + 1^2\nf(29) = 5^2 + 2^2\nf(34) = 5^2 + 3^2\nf(37) = 6^2 + 1^2\nf(41) = 5^2 + 4^2\nf(50) = 7^2 + 1^2\nf(53) = 7^2 + 2^2\nf(58) = 7^2 + 3^2\nf(61) = 6^2 + 5^2\nf(65) = 8^2 + 1^2\nf(73) = 8^2 + 3^2\nf(74) = 7^2 + 5^2\nf(82) = 9^2 + 1^2\nf(85) = 7^2 + 6^2\nf(89) = 8^2 + 5^2\nf(97) = 9^2 + 4^2\n"
  },
  {
    "path": "Math/primorial_deflation.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 15 April 2019\n# https://github.com/trizen\n\n# Represent a given number as a product of primorials (if possible).\n\n# The sequence of numbers that can be represented as a product of primorials, is given by:\n#   https://oeis.org/A025487\n\n# Among other terms, the sequence includes the factorials and the highly composite numbers.\n\n# See also:\n#   https://oeis.org/A181815 -- \"primorial deflation\" of A025487(n)\n#   https://oeis.org/A108951 -- \"primorial inflation\" of n\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures declared_refs);\n\nuse ntheory qw(factor factor_exp prev_prime);\nuse Math::AnyNum qw(factorial primorial prod ipow);\n\nsub primorial_deflation ($n) {\n\n    my @terms;\n\n    while ($n > 1) {\n\n        my $g = (factor($n))[-1];\n        my $p = primorial($g);\n\n        $n /= $p;\n        $n->is_int || return undef;\n\n        push @terms, $g;\n    }\n\n    return prod(@terms);\n}\n\nsub primorial_deflation_fast ($n) {\n\n    my @p;\n\n    foreach my \\@pp (factor_exp($n)) {\n        my ($p, $e) = @pp;\n        push @p, ($p == 2) ? 1 : ipow(prev_prime($p), $e);\n    }\n\n    $n / prod(@p);\n}\n\nmy @arr = map { primorial_deflation(factorial($_)) } 0 .. 15;    # https://oeis.org/A307035\n\nsay join ', ', @arr;                                                   #=> 1, 1, 2, 3, 12, 20, 60, 84, 672, 1512, 5040, 7920, 47520, 56160, 157248\nsay join ', ', map { prod(map { primorial($_) } factor($_)) } @arr;    #=> 1, 1, 2, 6, 24, 120, 720, 5040, 40320, 362880, 3628800, 39916800, 479001600, 6227020800, 87178291200\n\nmy @test = map { primorial_deflation_fast(factorial($_)) } 0 .. 15;\n\nif (\"@arr\" ne \"@test\") {\n    die \"error: (@arr) != (@test)\";\n}\n\nsay join ', ', map { primorial_deflation_fast($_) } 1..20;      # A319626 / A319627\n\nmy $n = Math::AnyNum->new(\"14742217487368791965347653720647452690286549052234444179664342042930370966727413549068727214664401976854238590421417268673037399536054005777393104248210539172848500736334237168727231561710827753972114334247396552090671649834020135652920430241738510495400044737265204738821393451152066370913670083496651044937158497896720493198891148968218874744806522767468280764179516341996273430700779982929787918221844760577694188288275419541410142336911631623319041967633591283303769044016192030492715535641753600000\");\n\nsay primorial_deflation($n);        #=> 52900585920\nsay primorial_deflation_fast($n);   #=> 52900585920\n"
  },
  {
    "path": "Math/pseudo_square_root.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 18 August 2017\n# https://github.com/trizen\n\n# Find the greatest divisor of `n` that does not exceed the square root of `n`.\n\n# See also:\n#   https://projecteuler.net/problem=266\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(factor_exp sqrtint vecmax);\n\nsub pseudo_square_root {\n    my ($n) = @_;\n\n    my $limit = sqrtint($n);\n\n    my @d  = (1);\n    my @pp = grep { $_->[0] <= $limit } factor_exp($n);\n\n    foreach my $pp (@pp) {\n\n        my $p = $pp->[0];\n        my $e = $pp->[1];\n\n        my @t;\n        my $r = 1;\n\n        for my $i (1 .. $e) {\n            $r *= $p;\n            foreach my $u (@d) {\n                push(@t, $u * $r) if ($u * $r <= $limit);\n            }\n        }\n\n        push @d, @t;\n    }\n\n    return vecmax(@d);\n}\n\nsay pseudo_square_root(479001600);     #=> 21600\nsay pseudo_square_root(6469693230);    #=> 79534\nsay pseudo_square_root(12398712476);   #=> 68\n"
  },
  {
    "path": "Math/pythagorean_triples.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 18 August 2016\n# Website: https://github.com/trizen\n\n# Generate Pythagorean triples whose sum goes up to a certain limit.\n\n# See also: https://projecteuler.net/problem=75\n#           https://en.wikipedia.org/wiki/Pythagorean_triple\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(gcd);\n\nsub pythagorean_triples {\n    my ($limit) = @_;\n\n    my @triples;\n    my $end = int(sqrt($limit));\n\n    foreach my $n (1 .. $end - 1) {\n        for (my $m = $n + 1 ; $m <= $end ; $m += 2) {\n\n            my $x = ($m**2 - $n**2);\n            my $y = (2 * $m * $n);\n            my $z = ($m**2 + $n**2);\n\n            last if $x + $y + $z > $limit;\n\n            if (gcd($n, $m) == 1) {    # n and m coprime\n\n                my $k = 1;\n\n                while (1) {\n                    my $x = $k * $x;\n                    my $y = $k * $y;\n                    my $z = $k * $z;\n\n                    last if $x + $y + $z > $limit;\n\n                    push @triples, [$x, $y, $z];\n                    ++$k;\n                }\n            }\n        }\n    }\n\n    map { $_->[1] } sort { $a->[0] <=> $b->[0] } map {\n        [$_->[0] + $_->[1] + $_->[2], [sort { $a <=> $b } @{$_}]]\n    } @triples;\n}\n\nmy @triples = pythagorean_triples(50);\n\nforeach my $triple (@triples) {\n    say \"P(@$triple) = \", $triple->[0] + $triple->[1] + $triple->[2];\n}\n\n__END__\nP(3 4 5) = 12\nP(6 8 10) = 24\nP(5 12 13) = 30\nP(9 12 15) = 36\nP(8 15 17) = 40\nP(12 16 20) = 48\n"
  },
  {
    "path": "Math/quadratic-integer_factorization_method.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 28 June 2020\n# https://github.com/trizen\n\n# A simple factorization method, using quadratic integers.\n# Similar in flavor to Pollard's p-1 and Williams's p+1 methods.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Quadratic_integer\n\nuse 5.020;\nuse warnings;\n\nuse ntheory qw(primes);\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload gcd ilog isqrt);\n\nsub quadratic_powmod ($a, $b, $w, $n, $m) {\n\n    my ($x, $y) = (1, 0);\n\n    do {\n        ($x, $y) = (($a * $x + $b * $y * $w) % $m, ($a * $y + $b * $x) % $m) if ($n & 1);\n        ($a, $b) = (($a * $a + $b * $b * $w) % $m, (2 * $a * $b) % $m);\n    } while ($n >>= 1);\n\n    ($x, $y);\n}\n\nsub quadratic_factorization ($n, $B, $a = 3, $b = 4, $w = 2) {\n\n    foreach my $p (@{primes(isqrt($B))}) {\n        ($a, $b) = quadratic_powmod($a, $b, $w, $p**ilog($B, $p), $n);\n    }\n\n    foreach my $p (@{primes(isqrt($B) + 1, $B)}) {\n\n        ($a, $b) = quadratic_powmod($a, $b, $w, $p, $n);\n\n        my $g = gcd($b, $n);\n\n        if ($g > 1) {\n            return 1 if ($g == $n);\n            return $g;\n        }\n    }\n\n    return 1;\n}\n\nsay quadratic_factorization(2**64 + 1, 20, 9, 2, 4);                 #=> 274177           (p-1 is   20-smooth)\nsay quadratic_factorization(257221 * 470783,               1000);    #=> 470783           (p-1 is 1000-smooth)\nsay quadratic_factorization(1124075136413 * 3556516507813, 4000);    #=> 1124075136413    (p+1 is 4000-smooth)\nsay quadratic_factorization(7553377229 * 588103349,        800);     #=> 7553377229       (p+1 is  800-smooth)\n\nsay '';\n\nsay quadratic_factorization(333732865481 * 1632480277613, 3000);     #=> 333732865481     (p-1 is 3000-smooth)\nsay quadratic_factorization(15597344393 * 12388291753,    3000);     #=> 15597344393      (p-1 is 3000-smooth)\nsay quadratic_factorization(43759958467 * 59037829639,    3200);     #=> 43759958467      (p+1 is 3200-smooth)\nsay quadratic_factorization(112601635303 * 83979783007,   700);      #=> 112601635303     (p-1 is  700-smooth)\nsay quadratic_factorization(228640480273 * 224774973299,  2000);     #=> 228640480273     (p-1 is 2000-smooth)\n\nsay '';\n\nsay quadratic_factorization(5140059121 * 8382882743,     2500);            #=> 5140059121       (p-1 is 2500-smooth)\nsay quadratic_factorization(18114813019 * 17402508649,   6000);            #=> 18114813019      (p+1 is 6000-smooth)\nsay quadratic_factorization(533091092393 * 440050095029, 300, 1, 2, 3);    #=> 533091092393     (p+1 is  300-smooth)\n"
  },
  {
    "path": "Math/quadratic-integer_factorization_method_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 28 June 2020\n# https://github.com/trizen\n\n# A simple factorization method, using quadratic integers.\n# Similar in flavor to Pollard's p-1 and Williams's p+1 methods.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Quadratic_integer\n\nuse 5.020;\nuse warnings;\n\nuse Math::GMPz;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub quadratic_powmod ($a, $b, $w, $n, $m) {\n\n    state $t = Math::GMPz::Rmpz_init_nobless();\n\n    my $x = Math::GMPz::Rmpz_init_set_ui(1);\n    my $y = Math::GMPz::Rmpz_init_set_ui(0);\n\n    do {\n\n        if ($n & 1) {\n            # (x, y) = ((a*x + b*y*w) % m, (a*y + b*x) % m)\n            Math::GMPz::Rmpz_mul_ui($t, $b, $w);\n            Math::GMPz::Rmpz_mul($t, $t, $y);\n            Math::GMPz::Rmpz_addmul($t, $a, $x);\n            Math::GMPz::Rmpz_mul($y, $y, $a);\n            Math::GMPz::Rmpz_addmul($y, $x, $b);\n            Math::GMPz::Rmpz_mod($x, $t, $m);\n            Math::GMPz::Rmpz_mod($y, $y, $m);\n        }\n\n        # (a, b) = ((a*a + b*b*w) % m, (2*a*b) % m)\n        Math::GMPz::Rmpz_mul($t, $a, $b);\n        Math::GMPz::Rmpz_mul_2exp($t, $t, 1);\n        Math::GMPz::Rmpz_powm_ui($a, $a, 2, $m);\n        Math::GMPz::Rmpz_powm_ui($b, $b, 2, $m);\n        Math::GMPz::Rmpz_addmul_ui($a, $b, $w);\n        Math::GMPz::Rmpz_mod($b, $t, $m);\n\n    } while ($n >>= 1);\n\n    Math::GMPz::Rmpz_set($a, $x);\n    Math::GMPz::Rmpz_set($b, $y);\n}\n\nsub quadratic_factorization ($n, $B, $a = 3, $b = 4, $w = 2) {\n\n    if (ref($n) ne 'Math::GMPz') {\n        $n = Math::GMPz->new(\"$n\");\n    }\n\n    $a = Math::GMPz::Rmpz_init_set_ui($a);\n    $b = Math::GMPz::Rmpz_init_set_ui($b);\n\n    my $g = Math::GMPz::Rmpz_init();\n\n    my $lnB = log($B);\n\n    foreach my $p (@{primes(sqrtint($B))}) {\n        quadratic_powmod($a, $b, $w, $p**int($lnB / log($p)), $n);\n    }\n\n    foreach my $p (@{primes(sqrtint($B) + 1, $B)}) {\n\n        quadratic_powmod($a, $b, $w, $p, $n);\n        Math::GMPz::Rmpz_gcd($g, $b, $n);\n\n        if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {\n            return 1 if (Math::GMPz::Rmpz_cmp($g, $n) == 0);\n            return $g;\n        }\n    }\n\n    return 1;\n}\n\nforeach my $n (\n#<<<\n    Math::GMPz->new(\"4687127904923490705199145598250386612169614860009202665502614423768156352727760127429892667212102542891417456048601608730032271\"),\n    Math::GMPz->new(\"2593364104508085171532503084981517253915662037671433715309875378319680421662639847819831785007087909697206133969480076353307875655764139224094652151\"),\n    Math::GMPz->new(\"850794313761232105411847937800407457007819033797145693534409492587965757152430334305470463047097051354064302867874781454865376206137258603646386442018830837206634789761772899105582760694829533973614585552733\"),\n#>>>\n  ) {\n\n    say \"\\n:: Factoring: $n\";\n\n    until (is_prime($n)) {\n\n        my ($a, $b, $w) = (int(rand(1e6)), int(rand(1e6)), int(rand(1e6)));\n\n        #say \"\\n# Trying with parameters = ($a, $b, $w)\";\n        my $p = quadratic_factorization($n, 500_000, $a, $b, $w);\n\n        if ($p > 1) {\n            say \"-> Found factor: $p\";\n            $n /= $p;\n        }\n    }\n}\n\n__END__\n:: Factoring: 4687127904923490705199145598250386612169614860009202665502614423768156352727760127429892667212102542891417456048601608730032271\n-> Found factor: 12993757635350024510533\n-> Found factor: 31935028572177122017\n-> Found factor: 441214532298715667413\n-> Found factor: 515113549791151291993\n-> Found factor: 896466791041143516471427\n\n:: Factoring: 2593364104508085171532503084981517253915662037671433715309875378319680421662639847819831785007087909697206133969480076353307875655764139224094652151\n-> Found factor: 2490501032020173490009\n-> Found factor: 1927199759971282921\n-> Found factor: 58637507352579687279739\n-> Found factor: 765996534730183701229\n-> Found factor: 4393290631695328772611\n-> Found factor: 85625333993726265061\n\n:: Factoring: 850794313761232105411847937800407457007819033797145693534409492587965757152430334305470463047097051354064302867874781454865376206137258603646386442018830837206634789761772899105582760694829533973614585552733\n-> Found factor: 556010720288850785597\n-> Found factor: 341190041753756943379\n-> Found factor: 33311699120128903709\n-> Found factor: 7672247345452118779313\n-> Found factor: 182229202433843943841\n-> Found factor: 5658991130760772523\n-> Found factor: 386663601339343857313\n-> Found factor: 55554864549706093104640631\n-> Found factor: 775828538119834346827\n"
  },
  {
    "path": "Math/quadratic_frobenius_primality_test.pl",
    "content": "#!/usr/bin/perl\n\n# A simple implemenetation of the Frobenius Quadratic pseudoprimality test.\n\n# Conditions:\n#   1. Make sure n is odd and is not a perfect power.\n#   2. Find the smallest odd prime p such that kronecker(p, n) = -1.\n#   3. Check if (1 + sqrt(p))^n == (1 - sqrt(p)) mod n.\n\n# Generalized test:\n#   1. Make sure n is odd and is not a perfect power.\n#   2. Find the smallest squarefree number c such that kronecker(c, n) = -1.\n#   3. Check if (a + b*sqrt(c))^n == (a - b*sqrt(c)) mod n, where a,b,c are all coprime with n.\n\n# No counter-examples are known to this test.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Quadratic_integer\n\nuse 5.020;\nuse warnings;\n\nuse Math::GMPz;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub quadratic_powmod ($x, $y, $a, $b, $w, $n, $m) {\n\n    state $t = Math::GMPz::Rmpz_init_nobless();\n\n    foreach my $bit (split(//, scalar reverse Math::GMPz::Rmpz_get_str($n, 2))) {\n\n        if ($bit) {\n\n            # (x, y) = ((a*x + b*y*w) % m, (a*y + b*x) % m)\n            Math::GMPz::Rmpz_mul_ui($t, $b, $w);\n            Math::GMPz::Rmpz_mul($t, $t, $y);\n            Math::GMPz::Rmpz_addmul($t, $a, $x);\n            Math::GMPz::Rmpz_mul($y, $y, $a);\n            Math::GMPz::Rmpz_addmul($y, $x, $b);\n            Math::GMPz::Rmpz_mod($x, $t, $m);\n            Math::GMPz::Rmpz_mod($y, $y, $m);\n        }\n\n        # (a, b) = ((a*a + b*b*w) % m, (2*a*b) % m)\n        Math::GMPz::Rmpz_mul($t, $a, $b);\n        Math::GMPz::Rmpz_mul_2exp($t, $t, 1);\n        Math::GMPz::Rmpz_powm_ui($a, $a, 2, $m);\n        Math::GMPz::Rmpz_powm_ui($b, $b, 2, $m);\n        Math::GMPz::Rmpz_addmul_ui($a, $b, $w);\n        Math::GMPz::Rmpz_mod($b, $t, $m);\n    }\n}\n\nsub find_discriminant ($n) {\n    for (my $p = 3 ; ; $p = next_prime($p)) {\n\n        my $k = Math::GMPz::Rmpz_ui_kronecker($p, $n);\n\n        if ($k == 0 and $p != $n) {\n            return undef;\n        }\n        elsif ($k == -1) {\n            return $p;\n        }\n    }\n}\n\nsub is_quadratic_frobenius_pseudoprime ($n) {\n\n    if (ref($n) ne 'Math::GMPz') {\n        $n = Math::GMPz->new(\"$n\");\n    }\n\n    return 0 if ($n <= 1);\n    return 1 if ($n == 2);\n\n    return 0 if Math::GMPz::Rmpz_even_p($n);\n    return 0 if Math::GMPz::Rmpz_perfect_power_p($n);\n\n    my $c = find_discriminant($n) // return 0;\n\n    state $a = Math::GMPz::Rmpz_init();\n    state $b = Math::GMPz::Rmpz_init();\n    state $w = Math::GMPz::Rmpz_init();\n\n    state $x = Math::GMPz::Rmpz_init();\n    state $y = Math::GMPz::Rmpz_init();\n\n    Math::GMPz::Rmpz_set_ui($a, 1);\n    Math::GMPz::Rmpz_set_ui($b, 1);\n    Math::GMPz::Rmpz_set_ui($w, $c);\n\n    Math::GMPz::Rmpz_set_ui($x, 1);\n    Math::GMPz::Rmpz_set_ui($y, 0);\n\n    quadratic_powmod($x, $y, $a, $b, $w, $n, $n);\n\n    Math::GMPz::Rmpz_congruent_p($x, $n - $n + 1, $n)\n      && Math::GMPz::Rmpz_congruent_p($y, $n - 1, $n);\n}\n\nmy $count = 0;\nforeach my $n (1 .. 1e5) {\n    if (is_quadratic_frobenius_pseudoprime($n)) {\n        ++$count;\n        if (!is_prime($n)) {\n            die \"Counter-example: $n\";\n        }\n    }\n    elsif (is_prime($n)) {\n        die \"Missed prime: $n\";\n    }\n}\n\nsay \"Count: $count\";    #=> Count: 9592\n"
  },
  {
    "path": "Math/quadratic_frobenius_pseudoprimes_generation.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 19 November 2023\n# https://github.com/trizen\n\n# A new algorithm for generating (almost) Quadratic-Frobenius pseudoprimes.\n\n# See also:\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse Math::AnyNum qw(prod);\nuse ntheory      qw(forcomb forprimes kronecker divisors);\n\nsub quadratic_powmod ($a, $b, $w, $n, $m) {\n\n    my ($x, $y) = (1, 0);\n\n    do {\n        ($x, $y) = (($a * $x + $b * $y * $w) % $m, ($a * $y + $b * $x) % $m) if ($n & 1);\n        ($a, $b) = (($a * $a + $b * $b * $w) % $m, (2 * $a * $b) % $m);\n    } while ($n >>= 1);\n\n    ($x, $y);\n}\n\nsub quadratic_frobenius_pseudoprimes ($limit, $callback) {\n\n    my %common_divisors;\n\n    my $c = 5;\n\n    forprimes {\n        my $p = $_;\n        foreach my $d (divisors($p - kronecker($c, $p))) {\n            if ($d > 1 and (quadratic_powmod(1, 1, $c, $d, $p))[0] == 1) {\n                push @{$common_divisors{$d}}, $p;\n            }\n        }\n    } 3, $limit;\n\n    my %seen;\n\n    foreach my $arr (values %common_divisors) {\n\n        my $l = $#{$arr} + 1;\n\n        foreach my $k (2 .. $l) {\n            forcomb {\n                my $n = prod(@{$arr}[@_]);\n                $callback->($n, @{$arr}[@_]) if !$seen{$n}++;\n            } $l, $k;\n        }\n    }\n}\n\nmy @pseudoprimes;\n\nquadratic_frobenius_pseudoprimes(\n    1e4,\n    sub ($n, @f) {\n        push @pseudoprimes, $n;\n    }\n);\n\n@pseudoprimes = sort { $a <=> $b } @pseudoprimes;\n\nsay join(', ', @pseudoprimes);\n\n__END__\n1891, 11663, 40501, 88831, 138833, 145351, 191351, 218791, 219781, 722261, 741751, 954271, 1123937, 1521187, 1690501, 1735841, 1963501, 2253751, 2741311, 2757241, 3568661, 3768451, 3996991, 4229551, 4686391, 5143823, 5323337, 5652191, 6368689, 6755251, 6976201, 7398151, 9031651, 9080191, 9493579, 9863461, 10036223, 10386241, 10403641, 15576571, 16253551, 18888379, 20234341, 22591301, 22669501, 22994371, 30186337, 74442383, 95413823, 5073193501, 21936153271\n"
  },
  {
    "path": "Math/quadratic_polynomial_in_terms_of_its_zeros.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 09 August 2017\n# https://github.com/trizen\n\n# Representation of quadratic polynomials in terms of their zeros.\n\n# Let:\n#    P(x) = a*x^2 + b*x + c\n\n# Let (m, n) be the solutions to P(x) = 0\n\n# Then:\n#   P(x) = c * (1 - x/m) * (1 - x/n)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::Bacovia qw(:all);\nuse Math::AnyNum qw(isqrt);\n\nsub integer_quadratic_formula {\n    my ($x, $y, $z) = @_;\n    (\n        Fraction((-$y + isqrt($y**2 - 4 * $x * $z)), (2 * $x)),\n        Fraction((-$y - isqrt($y**2 - 4 * $x * $z)), (2 * $x)),\n    );\n}\n\nmy @poly = (\n    [  3, -15,   -42],\n    [ 20, -97, -2119],\n    [-43,  29, 14972],\n);\n\nmy $x = Symbol('x');\n\nforeach my $t (@poly) {\n    my ($x1, $x2) = integer_quadratic_formula(@$t);\n\n    my $expr = $t->[0] * $x**2 + $t->[1] * $x + $t->[2];\n\n    my $f1 = (1 - $x / $x1);\n    my $f2 = (1 - $x / $x2);\n\n    printf(\"%s = %s * %s * %s\\n\",\n        $expr->pretty,\n        $f1->simple->pretty,\n        $f2->simple->pretty,\n        $t->[2],\n    );\n}\n\n__END__\n\n((3 * x^2) + (-15 * x) + -42) = (1 - (x/7)) * (1 - (x/-2)) * -42\n((20 * x^2) + (-97 * x) + -2119) = (1 - (x/13)) * (1 - (x/(-326/40))) * -2119\n((-43 * x^2) + (29 * x) + 14972) = (1 - (x/(-788/43))) * (1 - (x/19)) * 14972\n"
  },
  {
    "path": "Math/ramanujan_sum.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 26 July 2017\n# https://github.com/trizen\n\n# Ramanujan's sum:\n#   c_k(n) = Sum_{m mod k; gcd(m, k) = 1} exp(2*pi*i*m*n/k)\n\n# For n = 1, c_k(1) is equivalent to moebius(k).\n\n# For integer real values of `n` and `k`, Ramanujan's sum is equivalent to:\n#   c_k(n) = Sum_{m mod k; gcd(m, k) = 1} cos(2*pi*m*n/k)\n\n# Alternatively, when n = k, `c_n(n)` is equivalent with `euler_phi(n)`.\n\n# The record values, `c_n(n) + 1`, are the prime numbers.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload tau gcd round);\n\nsub ramanujan_sum {\n    my ($n, $k) = @_;\n\n    my $sum = 0;\n    foreach my $m (1 .. $k) {\n        if (gcd($m, $k) == 1) {\n            $sum += exp(tau * i * $m * $n / $k);\n        }\n    }\n\n    round($sum, -20);\n}\n\nmy $sum = 0;\nmy @partial_sums;\nforeach my $n (1 .. 30) {\n    my $r = ramanujan_sum($n, $n**2);\n    say \"R($n, $n^2) = $r\";\n    push @partial_sums, $sum += $r;\n}\n\nsay \"\\n=> Partial sums:\";\nsay join(' ', @partial_sums);\n\n__END__\nR(1, 1^2) = 1\nR(2, 2^2) = -2\nR(3, 3^2) = -3\nR(4, 4^2) = 0\nR(5, 5^2) = -5\nR(6, 6^2) = 6\nR(7, 7^2) = -7\nR(8, 8^2) = 0\nR(9, 9^2) = 0\nR(10, 10^2) = 10\nR(11, 11^2) = -11\nR(12, 12^2) = 0\nR(13, 13^2) = -13\nR(14, 14^2) = 14\nR(15, 15^2) = 15\nR(16, 16^2) = 0\nR(17, 17^2) = -17\nR(18, 18^2) = 0\nR(19, 19^2) = -19\nR(20, 20^2) = 0\nR(21, 21^2) = 21\nR(22, 22^2) = 22\nR(23, 23^2) = -23\nR(24, 24^2) = 0\nR(25, 25^2) = 0\nR(26, 26^2) = 26\nR(27, 27^2) = 0\nR(28, 28^2) = 0\nR(29, 29^2) = -29\nR(30, 30^2) = -30\n\n=> Partial sums:\n1 -1 -4 -4 -9 -3 -10 -10 -10 0 -11 -11 -24 -10 5 5 -12 -12 -31 -31 -10 12 -11 -11 -11 15 15 15 -14 -44\n"
  },
  {
    "path": "Math/ramanujan_sum_fast.pl",
    "content": "#!/usr/bin/perl\n\n# Efficient implementation of Ramanujan's sum.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(gcd euler_phi moebius);\n\nsub ramanujan_sum {\n    my ($n, $k) = @_;\n\n    my $g = $k / gcd($n, $k);\n    my $m = moebius($g);\n\n    $m * euler_phi($k) / euler_phi($g);\n}\n\nforeach my $n (1 .. 30) {\n    say ramanujan_sum($n, $n**2);\n}\n"
  },
  {
    "path": "Math/random_carmichael_fibonacci_pseudoprimes.pl",
    "content": "#!/usr/bin/perl\n\n# Generate random Carmichael numbers of the form:\n#   `n = p * (2*p - 1) * (3*p - 2) * (6*p - 5)`.\n\n# About half of this numbers are also Fibonacci pseudoprimes, satisfying:\n#   `Fibonacci(n - kronecker(n, 5)) = 0 (mod n)`.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\nuse ntheory qw(is_prob_prime random_nbit_prime);\n\nmy $bits = 50;    # bits of p\n\nforeach my $n (1 .. 1e6) {\n    my $p = Math::GMPz->new(random_nbit_prime($bits));\n\n    if (is_prob_prime(2 * $p - 1) && is_prob_prime(3 * $p - 2) && is_prob_prime(6 * $p - 5)) {\n        say $p * ($p * 2 - 1) * ($p * 3 - 2) * ($p * 6 - 5);\n    }\n}\n"
  },
  {
    "path": "Math/random_integer_factorization.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 19 May 2017\n# https://github.com/trizen\n\n# A very simple random integer factorization algorithm.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(random_prime);\n\nmy $n = 1355533 * 3672541;\nmy $r = int(sqrt($n));\n\nmy $x = $r;\nmy $y = $r;\n\nwhile (1) {\n    my $p = $x * $y;\n\n    last if $p == $n;\n\n    $x = random_prime(2, $r);\n    $y = int($n / $x);\n}\n\nsay \"$n = $x * $y\";\n"
  },
  {
    "path": "Math/random_miller-rabin_pseudoprimes.pl",
    "content": "#!/usr/bin/perl\n\n# Generate random probable Miller-Rabin pseudoprimes of the form:\n#\n#   `n = p * (2*p - 1)`\n#\n# where `2*p - 1` is also prime.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\nuse ntheory qw(:all);\n\nmy @bases = (2, 3, 5);    # Miller-Rabin pseudoprimes to these bases\nmy $bits  = 50;           # bits of p\n\nforeach my $n (1 .. 1e6) {\n    my $p = Math::GMPz->new(random_nbit_prime($bits));\n\n    if (is_prob_prime(2 * $p - 1)) {\n        my $n = $p * ($p * 2 - 1);\n\n        if (is_strong_pseudoprime($n, @bases)) {\n            say $n;\n        }\n    }\n}\n"
  },
  {
    "path": "Math/range_map.pl",
    "content": "#!/usr/bin/perl\n\n# Map a given value from a given range into another range.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub range_map {\n    my ($value, $in_min, $in_max, $out_min, $out_max) = @_;\n    ($value - $in_min) * ($out_max - $out_min) / ($in_max - $in_min) + $out_min;\n}\n\nsay range_map(5, 1, 10, 0, 4);    #=> 1.777... (maps the value 5 from range [1, 10] to range [0, 4])\nsay range_map(9, 1, 10, 1, 5);    #=> 4.555... (maps the value 9 from range [1, 10] to range [1, 5])\n"
  },
  {
    "path": "Math/rational_approximations.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 16 January 2019\n# https://github.com/trizen\n\n# Simple and efficient algorithm for finding the first continued-fraction convergents to a given real constant.\n\n# Continued-fraction convergents for PI:\n#   https://oeis.org/A002485\n#   https://oeis.org/A002486\n\n# See also:\n#   https://en.wikipedia.org/wiki/Continued_fraction\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload float);\n\nsub rational_approximations ($x, $callback, $first = 10) {\n\n    $x = float($x) || return;\n\n    my ($n1, $n2) = (0, 1);\n    my ($d1, $d2) = (1, 0);\n\n    my $f = $x;\n\n    for (1 .. $first) {\n        my $z = int($f);\n\n        $n1 += $n2 * $z;\n        $d1 += $d2 * $z;\n\n        ($n1, $n2) = ($n2, $n1);\n        ($d1, $d2) = ($d2, $d1);\n\n        $callback->($n2 / $d2);\n\n        $f -= $z;\n        $f || last;\n        $f = 1 / $f;\n    }\n}\n\nmy $x = atan2(0, -1);\nmy $f = sub ($q) { say \"PI =~ $q\" };\n\nrational_approximations($x, $f, 20);\n\n__END__\nPI =~ 3\nPI =~ 22/7\nPI =~ 333/106\nPI =~ 355/113\nPI =~ 103993/33102\nPI =~ 104348/33215\nPI =~ 208341/66317\nPI =~ 312689/99532\nPI =~ 833719/265381\nPI =~ 1146408/364913\nPI =~ 4272943/1360120\nPI =~ 5419351/1725033\nPI =~ 80143857/25510582\nPI =~ 165707065/52746197\nPI =~ 245850922/78256779\nPI =~ 411557987/131002976\nPI =~ 1068966896/340262731\nPI =~ 2549491779/811528438\nPI =~ 6167950454/1963319607\nPI =~ 14885392687/4738167652\n"
  },
  {
    "path": "Math/rational_continued_fractions.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 31 July 2016\n# Website: https://github.com/trizen\n\n# Recursive evaluation of continued fractions rationally,\n# by computing the numerator and the denominator individually.\n\n# For every continued fraction, we have the following relation:\n#\n#    n\n#   | / a(k)    kn(n)\n#   |/ ----- = -------\n#   | \\ b(k)    kd(n)\n#   k=0\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Memoize qw(memoize);\n\nno warnings qw(recursion);\nuse experimental qw(signatures);\n\nmemoize('kn');\nmemoize('kd');\n\nsub a($n) {\n    $n**2;\n}\n\nsub b($n) {\n    2 * $n + 1;\n}\n\nsub kn($n) {\n    $n < 2\n      ? ($n == 0 ? 1 : 0)\n      : b($n - 1) * kn($n - 1) + a($n - 1) * kn($n - 2);\n}\n\nsub kd($n) {\n    $n < 2\n      ? $n\n      : b($n - 1) * kd($n - 1) + a($n - 1) * kd($n - 2);\n}\n\nfor my $i (0 .. 10) {\n    printf(\"%2d. %20d %20d\\n\", $i, kn($i), kd($i));\n}\n"
  },
  {
    "path": "Math/rational_prime_product.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 17 June 2017\n# https://github.com/trizen\n\n# Prime product, related to the zeta function.\n\n# ___\n# | | (p^(2n) - 1) / (p^(2n) + 1) = {2/5, 6/7, 691/715, 7234/7293, 523833/524875, ...}\n#  p\n\n# Example:\n#   Product_{n >= 1} (prime(n)^2 - 1)/(prime(n)^2 + 1) = 2/5\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(forprimes);\n\nmy $n = 2;\n\n{\n    my $prod = 1;\n    forprimes {\n        $prod *= ($_**$n + 1) / ($_**$n - 1);\n    } 1e7;\n\n    say $prod;\n}\n\n{\n    my $prod = 1;\n    forprimes {\n        $prod *= ($_**$n + 1) / ($_**$n - 1);\n    } 1e8;\n\n    say $prod;\n    say 1 / $prod;\n}\n\n__END__\n2.49999997066443\n2.49999999690776\n0.400000000494758\n"
  },
  {
    "path": "Math/rational_summation_of_fractions.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 23 June 2016\n# Website: https://github.com/trizen\n\n# Rationalized summation of fractions, based on the identity:\n#\n#  a     c     ad + bc\n# --- + --- = ----------\n#  b     d       bd\n\n# Combining this method with memoization, results in a practical\n# generalized algorithm for summation of arbitrary fractions.\n\n# In addition, with this method, any infinite sum can be converted into a limit.\n\n# Example:                ∞\n#            f(n)        ---  1\n#  lim    ----------  =  \\   ----  = e\n#  n->∞      _n_         /    n!\n#            | | k!      ---\n#            k=0         n=0\n#\n# where:                     _n_\n#   f(n+1) = (n+1)! * f(n) + | | k!\n#                            k=0\n#   f(0)   = 1\n#\n#====================================================\n#\n# Generally:\n#\n#   x\n#  ---\n#  \\    a(n)       f(x)\n#   -  ------  =  ------\n#  /    b(n)       g(x)\n#  ---\n#  n=0\n#\n# where:\n# | f(0) = a(0)\n# | f(n) = b(n) * f(n-1) + a(n) * g(n-1)\n#\n# and:\n# | g(0) = b(0)\n# | g(n) = b(n) * g(n-1)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Memoize qw(memoize);\nuse Math::AnyNum qw(:overload factorial);\n\nmemoize('b');\nmemoize('f');\nmemoize('g');\n\nmy $start = 0;     # start iteration from this value\nmy $iter  = 90;    # number of iterations\n\nsub a {\n    2**$_[0];\n}\n\nsub b {\n    factorial($_[0]);\n}\n\nsub f {\n    my ($n) = @_;\n    $n <= $start\n      ? a($n)\n      : b($n) * f($n - 1) + a($n) * g($n - 1);\n}\n\nsub g {\n    my ($n) = @_;\n    $n <= $start\n      ? b($n)\n      : b($n) * g($n - 1);\n}\n\nmy $x = f($iter) / g($iter);\nsay $x;\nsay \"e^2 =~ \", $x->as_dec(64);\n"
  },
  {
    "path": "Math/reciprocal_cycle_length.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 17 May 2020\n# https://github.com/trizen\n\n# Algorithm for finding the length of the recurring cycle of 1/n in base b.\n\nuse 5.020;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub reciprocal_cycle_length ($n, $base = 10) {\n\n    for (my $g = gcd($n, $base) ; $g > 1 ; $g = gcd($n, $base)) {\n        $n /= $g;\n    }\n\n    ($n == 1) ? 0 : znorder($base, $n);\n}\n\nforeach my $n (1 .. 20) {\n    my $r = reciprocal_cycle_length($n);\n    say \"1/$n has cycle length of $r\";\n}\n\n__END__\n1/1 has cycle length of 0\n1/2 has cycle length of 0\n1/3 has cycle length of 1\n1/4 has cycle length of 0\n1/5 has cycle length of 0\n1/6 has cycle length of 1\n1/7 has cycle length of 6\n1/8 has cycle length of 0\n1/9 has cycle length of 1\n1/10 has cycle length of 0\n1/11 has cycle length of 2\n1/12 has cycle length of 1\n1/13 has cycle length of 6\n1/14 has cycle length of 6\n1/15 has cycle length of 1\n1/16 has cycle length of 0\n1/17 has cycle length of 16\n1/18 has cycle length of 1\n1/19 has cycle length of 18\n1/20 has cycle length of 0\n"
  },
  {
    "path": "Math/rectangle_sides_from_area_and_diagonal.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 22 January 2018\n# https://github.com/trizen\n\n# Formula for finding the length of the sides of a rectangle\n# when only its area and the length of its diagonal are known.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Fermat%27s_factorization_method\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub extract_rectangle_sides {\n    my ($n, $h) = @_;\n\n    my $s = (2 * $n + $h);\n\n    my $x = sqrt($s - 4 * $n) / 2;\n    my $y = sqrt($s) / 2;\n\n    return ($y - $x, $x + $y);\n}\n\nmy $p = 43;\nmy $q = 97;\n\nmy $n = $p * $q;          # rectangle area\nmy $h = $p**2 + $q**2;    # diagonal length, squared\n\nsay join(' ', extract_rectangle_sides($n, $h));\n"
  },
  {
    "path": "Math/rectangle_sides_from_diagonal_angles.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 22 January 2018\n# https://github.com/trizen\n\n# Formula for finding the smallest integer sides of a rectangle, given the internal angles of its diagonal.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:trig :overload);\n\nsub diagonal_angles ($x, $y, $z) {\n    (\n        acos(($x**2 + $z**2 - $y**2) / (2 * $x * $z)),\n        acos(($y**2 + $z**2 - $x**2) / (2 * $y * $z)),\n    );\n}\n\nsub rectangle_side_from_angle ($theta) {\n    sqrt((cos($theta)**2)->rat_approx->numerator);\n}\n\nmy $x = 43;                         # side 1\nmy $y = 97;                         # side 2\nmy $z = sqrt($x**2 + $y**2);        # diagonal\n\nmy ($a1, $a2) = diagonal_angles($x, $y, $z);\n\nsay \"The internal diagonal angles:\";\nsay '  ', rad2deg($a1);     #=> 66.0923395058274991877532084833790002675999587054\nsay '  ', rad2deg($a2);     #=> 23.9076604941725008122467915166209997324000412946\n\nsay \"\\nThe smallest side lengths matching the internal angles:\";\nsay rectangle_side_from_angle($a1);         #=> 43\nsay rectangle_side_from_angle($a2);         #=> 97\n"
  },
  {
    "path": "Math/rectangle_sides_from_one_diagonal_angle.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 22 January 2018\n# https://github.com/trizen\n\n# Formula for finding the smallest integer sides of a rectangle, given one internal angle of its diagonal.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:trig :overload);\n\nsub rectangle_sides_from_angle ($theta) {\n    tan($theta)->rat_approx->nude;\n}\n\nmy $x = 43;    # side 1\nmy $y = 97;    # side 2\n\nmy $theta = atan2($x, $y);\n\nsay \"A rectangle internal diagonal angle:\";\nsay '  ', rad2deg($theta);    #=> 23.9076604941725008122467915166209997324000412946\n\nsay \"\\nThe smallest integer sides matching the internal angle:\";\nsay join(' ', rectangle_sides_from_angle($theta));    #=> 43 97\n"
  },
  {
    "path": "Math/recursive_matrix_multiplication.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 04 April 2016\n# Website: https://github.com/trizen\n\n# Recursive matrix multiplication, using a divide and conquer algorithm.\n# See also: https://en.wikipedia.org/wiki/Matrix_multiplication\n\n# NOTE: works only with n*n matrices, where n must be a power of 2.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub add {\n    my ($A, $B) = @_;\n\n    my $C = [[]];\n\n    foreach my $i (0 .. $#{$A}) {\n        foreach my $j (0 .. $#{$A->[$i]}) {\n            $C->[$i][$j] += $A->[$i][$j] + $B->[$i][$j];\n        }\n    }\n\n    $C;\n}\n\nsub msplit {\n    my ($A, $B, $C, $D) = @_;\n\n    my $end = $#{$A};\n    my $mid = int($end / 2);\n\n    my @A = @{$A}[0 .. $mid];\n    my @B = @{$B}[0 .. $mid];\n\n    my @C = @{$A}[$mid + 1 .. $end];\n    my @D = @{$B}[$mid + 1 .. $end];\n\n    my @E = @{$C}[0 .. $mid];\n    my @F = @{$D}[0 .. $mid];\n\n    my @G = @{$C}[$mid + 1 .. $end];\n    my @H = @{$D}[$mid + 1 .. $end];\n\n#<<<\n    if ($end > 3) {\n        return\n            msplit(\\@A, \\@C, \\@B, \\@D),\n            msplit(\\@E, \\@G, \\@F, \\@H);\n    }\n#>>>\n\n#<<<\n    [\n        [@A, @B],\n        [@C, @D],\n        [@E, @F],\n        [@G, @H],\n    ]\n#>>>\n}\n\n#\n## Known issue: broken\n#\nsub merge_rows {\n    my (@blocks) = @_;\n\n    if (@{$blocks[0]} > 4) {\n\n        my @merged;\n        while (@{$blocks[0]}) {\n            my @rows;\n            foreach my $block (@blocks) {\n                push @rows, [splice(@{$block}, 0, 4)];\n            }\n            push @merged, @{merge_rows(@rows)};\n        }\n\n        return \\@merged;\n    }\n\n    my @A;\n\n    foreach my $i (0 .. 3) {\n        push @{$A[$i]}, @{$blocks[0][$i]}, @{$blocks[1][$i]};\n        push @{$A[$i + 4]}, @{$blocks[2][$i]}, @{$blocks[3][$i]};\n    }\n\n    return \\@A;\n}\n\n#\n## Known issue: broken\n#\nsub merge {\n    my (@blocks) = @_;\n\n    while (@blocks > 4) {\n        push @blocks, merge_rows(splice(@blocks, 0, 4));\n    }\n\n    return merge_rows(@blocks);\n}\n\nsub mul {\n    my ($A, $B) = @_;\n\n    ## Base case:\n#<<<\n    if ($#{$A} == 1 and $#{$A->[0]} == 1 and $#{$B} == 1 and $#{$B->[0]} == 1) {\n        return [\n            [\n                $A->[0][0] * $B->[0][0] + $A->[0][1] * $B->[1][0],\n                $A->[0][0] * $B->[0][1] + $A->[0][1] * $B->[1][1],\n            ],\n            [\n                $A->[1][0] * $B->[0][0] + $A->[1][1] * $B->[1][0],\n                $A->[1][0] * $B->[0][1] + $A->[1][1] * $B->[1][1],\n            ],\n        ];\n    }\n#>>>\n\n    my $end = $#{$A};\n    my $mid = int($end / 2);\n\n    my @A = map { [@{$_}[0 .. $mid]] } @{$A}[0 .. $mid];\n    my @B = map { [@{$_}[$mid + 1 .. $end]] } @{$A}[0 .. $mid];\n\n    my @C = map { [@{$_}[0 .. $mid]] } @{$A}[$mid + 1 .. $end];\n    my @D = map { [@{$_}[$mid + 1 .. $end]] } @{$A}[$mid + 1 .. $end];\n\n    my @E = map { [@{$_}[0 .. $mid]] } @{$B}[0 .. $mid];\n    my @F = map { [@{$_}[$mid + 1 .. $end]] } @{$B}[0 .. $mid];\n\n    my @G = map { [@{$_}[0 .. $mid]] } @{$B}[$mid + 1 .. $end];\n    my @H = map { [@{$_}[$mid + 1 .. $end]] } @{$B}[$mid + 1 .. $end];\n\n#<<<\n    [\n        (\n            [map{@{$_}} @{add(mul(\\@A, \\@E), mul(\\@B, \\@G))}],\n            [map{@{$_}} @{add(mul(\\@A, \\@F), mul(\\@B, \\@H))}],\n            [map{@{$_}} @{add(mul(\\@C, \\@E), mul(\\@D, \\@G))}],\n            [map{@{$_}} @{add(mul(\\@C, \\@F), mul(\\@D, \\@H))}]\n        ),\n    ];\n#>>>\n}\n\nsub mmult {\n    our @a;\n    local *a = shift;\n    our @b;\n    local *b = shift;\n    my @p    = [];\n    my $rows = @a;\n    my $cols = @{$b[0]};\n    my $n    = @b - 1;\n    for (my $r = 0 ; $r < $rows ; ++$r) {\n\n        for (my $c = 0 ; $c < $cols ; ++$c) {\n            foreach (0 .. $n) {\n                $p[$r][$c] += $a[$r][$_] * $b[$_][$c];\n            }\n        }\n    }\n    return [@p];\n}\n\nsub new_matrix {\n    my ($n) = @_;\n    [map { [$n * $_ - $n + 1 .. $_ * $n] } 1 .. $n];\n}\n\nsub display_matrix {\n    my ($A, $w) = @_;\n    say join(\n        \"\\n\",\n        map {\n            join(' ', map { sprintf(\"%${w}d\", $_) } @{$_})\n          } @{$A}\n    );\n}\n\n#\n## Demo:\n#\n\nmy $A = [[3, 4], [5, 6]];\n\nuse Data::Dump qw(pp);\npp mul($A, $A);\npp mmult($A, $A);\n\nmy $B = new_matrix(4);\n\npp mmult($B, $B);\npp mul($B, $B);\n\nmy $C = new_matrix(8);\nmy $D = mmult($C, $C);\n\ndisplay_matrix($D, 6);\n\nmy $x = mul($C, $C);\npp msplit(@{$x});\n"
  },
  {
    "path": "Math/rest_calc.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 14 January 2013\n# https://github.com/trizen\n\n# Calculates how to give back some amount of money.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nmy @steps = (500, 200, 100, 50, 10, 5, 1, 0.5, 0.1, 0.05, 0.01);\n\nmy $rest = shift // 9999.99;\n\nforeach my $i (@steps) {\n    my $x = 0;\n    while ($rest >= $i) {\n        ++$x;\n        $rest -= $i;\n    }\n    if ($x) {\n        say \"$x x $i\";\n        last if $rest == 0;\n    }\n}\n"
  },
  {
    "path": "Math/reversed_number_triangle.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 26 July 2015\n# Website: https://github.com/trizen\n\n# Generate a \"reversed\" number triangle.\n\nmy $rows = 6;\nmy @arr  = ([1]);\n\nmy $n = 1;\nforeach my $i (1 .. $rows) {\n\n    foreach my $j (reverse 0 .. $#arr) {\n        push @{$arr[$j]}, ++$n;\n        unshift @{$arr[$j]}, ++$n;\n    }\n\n    unshift @arr, [++$n];\n}\n\nforeach my $row (@arr) {\n    print \" \" x (3 * $rows--);\n    print map { sprintf \"%3d\", $_ } @{$row};\n    print \"\\n\";\n}\n"
  },
  {
    "path": "Math/reversed_number_triangles.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 26 July 2015\n# Website: https://github.com/trizen\n\n# Generate a set of interesting numeric triangles.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub triangle {\n    my ($rows, $type) = @_;\n\n    my @triangle = ([1]);\n\n    my $n = 1;\n    foreach my $i (1 .. $rows) {\n\n        if ($type == 1) {\n            foreach my $j (0 .. $#triangle) {\n                push @{$triangle[$j]}, ++$n;\n                unshift @{$triangle[$j]}, ++$n;\n            }\n        }\n        elsif ($type == 2) {\n            foreach my $j (reverse 0 .. $#triangle) {\n                push @{$triangle[$j]}, ++$n;\n                unshift @{$triangle[$j]}, ++$n;\n            }\n        }\n        elsif ($type == 3) {\n            foreach my $j (0 .. $#triangle) {\n                unshift @{$triangle[$j]}, ++$n;\n            }\n            foreach my $j (reverse 0 .. $#triangle) {\n                push @{$triangle[$j]}, ++$n;\n            }\n        }\n        elsif ($type == 4) {\n            foreach my $j (reverse 0 .. $#triangle) {\n                unshift @{$triangle[$j]}, ++$n;\n            }\n            foreach my $j (0 .. $#triangle) {\n                push @{$triangle[$j]}, ++$n;\n            }\n        }\n        else {\n            die \"Invalid type: $type\";\n        }\n\n        unshift @triangle, [++$n];\n    }\n\n    return \\@triangle;\n}\n\nmy $width = 4;\nmy $rows  = 8;\n\nforeach my $i (1 .. 4) {\n    my $triangle = triangle($rows, $i);\n\n    foreach my $i (0 .. $#{$triangle}) {\n        my $row = $triangle->[$i];\n        print \" \" x ($width * ($rows - $i));\n        print map { sprintf \"%*d\", $width, $_ } @{$row};\n        print \"\\n\";\n    }\n    print \"-\" x ($width * ($rows + 1) * 2 - $width), \"\\n\";\n}\n"
  },
  {
    "path": "Math/riemann_prime-counting_function.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 27 February 2019\n# https://github.com/trizen\n\n# Compute the Riemann prime-power counting function for 10^n.\n\n# OEIS sequences:\n#   https://oeis.org/A322713 -- numerator of the Riemann prime counting function for 10^n.\n#   https://oeis.org/A322714 -- denominator of the Riemann prime counting function for 10^n.\n\n# See also:\n#   https://mathworld.wolfram.com/RiemannPrimeCountingFunction.html\n#   https://en.wikipedia.org/wiki/Arithmetic_function#%CF%80(x),_%CE%A0(x),_%CE%B8(x),_%CF%88(x)_%E2%80%93_prime_count_functions\n\n# PARI program:\n#   a(n) = sum(k=1, logint(n, 2), primepi(sqrtnint(n, k))/k);\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(prime_count);\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload iroot ipow10 ilog2);\n\nmy %primepi_lookup = (    # https://oeis.org/A006880\n                       ipow10(0)  => 0,\n                       ipow10(1)  => 4,\n                       ipow10(2)  => 25,\n                       ipow10(3)  => 168,\n                       ipow10(4)  => 1229,\n                       ipow10(5)  => 9592,\n                       ipow10(6)  => 78498,\n                       ipow10(7)  => 664579,\n                       ipow10(8)  => 5761455,\n                       ipow10(9)  => 50847534,\n                       ipow10(10) => 455052511,\n                       ipow10(11) => 4118054813,\n                       ipow10(12) => 37607912018,\n                       ipow10(13) => 346065536839,\n                       ipow10(14) => 3204941750802,\n                       ipow10(15) => 29844570422669,\n                       ipow10(16) => 279238341033925,\n                       ipow10(17) => 2623557157654233,\n                       ipow10(18) => 24739954287740860,\n                       ipow10(19) => 234057667276344607,\n                       ipow10(20) => 2220819602560918840,\n                       ipow10(21) => 21127269486018731928,\n                       ipow10(22) => 201467286689315906290,\n                       ipow10(23) => 1925320391606803968923,\n                       ipow10(24) => 18435599767349200867866,\n                       ipow10(25) => 176846309399143769411680,\n                       ipow10(26) => 1699246750872437141327603,\n                       ipow10(27) => 16352460426841680446427399,\n                     );\n\nsub primepi ($n) {\n    $primepi_lookup{$n} //= Math::AnyNum->new(prime_count($n));\n}\n\nsub riemann_prime_power_count ($n) {\n\n    my $sum = Math::AnyNum->new(0);\n\n    foreach my $k (1 .. ilog2($n)) {\n        $sum += primepi(iroot($n, $k)) / $k;\n    }\n\n    return $sum;\n}\n\nforeach my $k (0 .. 27) {\n    my $riemann_pi = riemann_prime_power_count(ipow10($k));\n    printf(\"RiemannPI(10^%s) = %s / %s\\n\", $k, $riemann_pi->nude);\n}\n\n__END__\nRiemannPI(10^0) = 0 / 1\nRiemannPI(10^1) = 16 / 3\nRiemannPI(10^2) = 428 / 15\nRiemannPI(10^3) = 445273 / 2520\nRiemannPI(10^4) = 56175529 / 45045\nRiemannPI(10^5) = 991892879 / 102960\nRiemannPI(10^6) = 18296822833013 / 232792560\nRiemannPI(10^7) = 3559637526370229 / 5354228880\nRiemannPI(10^8) = 6427431691337929 / 1115464350\nRiemannPI(10^9) = 14804074778750628149 / 291136195350\nRiemannPI(10^10) = 9387415960571046321167 / 20629078984800\nRiemannPI(10^11) = 594663752918349842404169 / 144403552893600\nRiemannPI(10^12) = 200936708396848319452718531 / 5342931457063200\nRiemannPI(10^13) = 296345083061712053722716462103 / 856326196254765600\nRiemannPI(10^14) = 30189234512048649753828116713823 / 9419588158802421600\nRiemannPI(10^15) = 92489654985220588144991271054976597 / 3099044504245996706400\nRiemannPI(10^16) = 1146617973013522976708984977425080657 / 4106233968125945635980\nRiemannPI(10^17) = 43091758212832458215850119943990751261 / 16424935872503782543920\nRiemannPI(10^18) = 29968472027360099705216121701124772705819 / 1211339020597153962614100\nRiemannPI(10^19) = 34589828635127927869863999345206682161220613 / 147783360512852783438920200\nRiemannPI(10^20) = 138189551154910199110253731685916742453919111 / 62224572847516961447966400\nRiemannPI(10^21) = 88080566389377854878591135538815093294467340937 / 4169046380783636417013748800\nRiemannPI(10^22) = 82713438240421499874570664161132532019632247186099473 / 410555180440430163438262940577600\nRiemannPI(10^23) = 263483420261441147355705259456363418174163088008435757 / 136851726813476721146087646859200\nRiemannPI(10^24) = 199312549377508874879173849072922864723503113431443720379 / 10811286418264660970540924101876800\nRiemannPI(10^25) = 1428216268887073538506983112166274277395419122408122239510533 / 8076030954443701744994070304101969600\nRiemannPI(10^26) = 13723169359285085091924336231689687414362369542759969479728573 / 8076030954443701744994070304101969600\nRiemannPI(10^27) = 21331406381807452349995058664653365273837322008799142085480723 / 1304476869229563439754033134419374400\n"
  },
  {
    "path": "Math/riemann_s_J_function.pl",
    "content": "#!/usr/bin/perl\n\n# Riemann's J function\n# J(x) = Σ 1/k π(⌊x^(1/k)⌋)\n\nuse strict;\nuse warnings;\n\nuse ntheory qw(prime_count);\n\nsub J {\n    my ($x) = @_;\n\n    my $sum = 0;\n\n    my $k = 1;\n    while (1) {\n        my $pi = prime_count(int($x**(1 / $k)));\n        last if $pi == 0;\n        $sum += 1 / $k++ * $pi;\n    }\n\n    $sum;\n}\n\nforeach my $k (1 .. 99) {\n    printf(\"J(%2d) = %s\\n\", $k, J($k));\n}\n"
  },
  {
    "path": "Math/roots_on_the_rise.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 21 February 2018\n# https://github.com/trizen\n\n# Solutions to x for:\n#    1/x = (k/x)^2 * (k + x^2) - k*x\n\n# See also:\n#   https://projecteuler.net/problem=479\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload);\n#use Math::GComplex qw(:overload);\n\nsub roots ($k) {\n\n    # Formulas from Wolfram|Alpha\n    # https://www.wolframalpha.com/input/?i=1%2Fx+%3D+(k%2Fx)%5E2+*+(k%2Bx%5E2)++-+k*x\n\n#<<<\n    my $x1 = (2*$k**6 + 27 * $k**5 - 9*$k**3 + 3 * sqrt(3) * sqrt(4 * $k**11 + 27 * $k**10 -\n    18*$k**8 - $k**6 + 4 *$k**3))**(1/3)/(3 * 2**(1/3) * $k) - (2**(1/3) * (3 * $k - $k**4)\n    )/(3 * (2* $k**6 + 27 * $k**5 - 9 * $k**3 + 3*sqrt(3) * sqrt(4*$k**11 + 27*$k**10 - 18 *\n    $k**8 - $k**6 + 4 *$k**3))**(1/3) *$k) + $k/3;\n\n    my $x2 = -((1 - i * sqrt(3)) * (2 * $k**6 + 27 *$k**5 - 9 * $k**3 + 3 * sqrt(3) * sqrt(4 *\n    $k**11 + 27* $k**10 - 18* $k**8 - $k**6 + 4 * $k**3))**(1/3))/(6 * 2**(1/3) * $k) +\n    ((1 + i * sqrt(3)) * (3 * $k - $k**4))/(3 * 2**(2/3) * (2 * $k**6 + 27 * $k**5 - 9 *\n    $k**3 + 3 * sqrt(3) * sqrt(4 * $k**11 + 27 * $k**10 - 18 * $k**8 - $k**6 + 4 * $k**3)\n    )**(1/3) * $k) + $k/3;\n\n    my $x3 = -((1 + i * sqrt(3)) * (2*$k**6 + 27 * $k**5 - 9 * $k**3 + 3 * sqrt(3) * sqrt(4 *\n    $k**11 + 27 * $k**10 - 18 * $k**8 - $k**6 + 4 * $k**3))**(1/3))/(6 * 2**(1/3) * $k) +\n    ((1 - i * sqrt(3)) * (3 * $k - $k**4))/(3 * 2**(2/3) * (2 *$k**6 + 27 * $k**5 - 9 * $k**3 +\n    3 * sqrt(3) * sqrt(4 *$k**11 + 27 * $k**10 - 18 *$k**8 - $k**6 + 4 * $k**3))**(1/3) * $k) + $k/3;\n#>>>\n\n    return ($x1, $x2, $x3);\n}\n\nsub S ($n) {\n    my $sum = 0;\n\n    foreach my $k (1 .. $n) {\n\n        my ($x1, $x2, $x3) = roots($k);\n\n        foreach my $p (1 .. $n) {\n            my $t = ($x1 + $x2)**$p * ($x2 + $x3)**$p * ($x3 + $x1)**$p;\n            say \"$k -> $t\";\n            $sum += $t;\n        }\n\n        say '';\n    }\n\n    return $sum;\n}\n\nsub S_int ($n) {\n    my $sum = 0;\n    foreach my $k (1 .. $n - 1) {\n        my $p = ($k + 1)**2 - 1;\n        $sum += ($p * ((-1)**$n * $p**$n - 1)) / ($p + 1);\n    }\n    return $sum;\n}\n\nsay S(4);\nsay S_int(4);\n"
  },
  {
    "path": "Math/secant_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Algorithm for computing the secant numbers (also known as Euler numbers):\n#\n#   1, 1, 5, 61, 1385, 50521, 2702765, 199360981, 19391512145, 2404879675441, 370371188237525, ...\n#\n\n# Algorithm presented in the book:\n#\n#   Modern Computer Arithmetic\n#           - by Richard P. Brent and Paul Zimmermann\n#\n\n# See also:\n#   https://oeis.org/A000364\n#   https://en.wikipedia.org/wiki/Euler_number\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\n\nsub secant_numbers {\n    my ($n) = @_;\n\n    my @S = (Math::GMPz::Rmpz_init_set_ui(1));\n\n    foreach my $k (1 .. $n) {\n        Math::GMPz::Rmpz_mul_ui($S[$k] = Math::GMPz::Rmpz_init(), $S[$k - 1], $k);\n    }\n\n    foreach my $k (1 .. $n) {\n        foreach my $j ($k + 1 .. $n) {\n            Math::GMPz::Rmpz_addmul_ui($S[$j], $S[$j - 1], ($j - $k + 2) * ($j - $k));\n        }\n    }\n\n    return @S;\n}\n\nsay join(', ', secant_numbers(10));\n"
  },
  {
    "path": "Math/semiprime_equationization.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 09 July 2015\n# Website: https://github.com/trizen\n\n# Split a semiprime into a group of equations.\n\nuse 5.016;\nuse strict;\nuse integer;\nuse warnings;\n\nsub semiprime_equationization {\n    my ($semiprime, $xlen, $ylen) = @_;\n\n    $xlen -= 1;\n    $ylen -= 1;\n\n    my @map;\n    my $mem = '0';\n    my @result;\n\n    my %vars;\n    foreach my $j (0 .. $ylen) {\n        foreach my $i (0 .. $xlen) {\n            my $expr = '(' . join(' + ', \"(x[$i] * y[$j])\", grep { $_ ne '0' } $mem) . ')';\n\n            $vars{\"xy$i$j\"} = $expr;\n            my $n = \"xy$i$j\";\n\n            if ($i == $xlen) {\n                push @{$map[$j]}, \"($n % 10)\", \"int($n / 10)\";\n                $mem = '0';\n            }\n            else {\n                push @{$map[$j]}, \"($n % 10)\";\n                $mem = \"int($n / 10)\";\n            }\n        }\n\n        my $n = $ylen - $j;\n        if ($n > 0) {\n            push @{$map[$j]}, ((0) x $n);\n        }\n\n        my $m = $ylen - $n;\n        if ($m > 0) {\n            unshift @{$map[$j]}, ((0) x $m);\n        }\n    }\n\n    my @number = reverse split //, $semiprime;\n    my @mrange = (0 .. $#map);\n\n    my %seen;\n    my $initializer = sub {\n        my ($str) = @_;\n        while ($str =~ /\\b(xy\\d+)/g) {\n            if (not $seen{$1}++) {\n                my $init = \"$1 = $vars{$1}\";\n                __SUB__->($init);\n                push @result, $init;\n            }\n        }\n    };\n\n    foreach my $i (0 .. $#number) {\n        my $expr = '(' . join(' + ', grep { $_ ne '0' } (map { $map[$_][$i] } @mrange), $mem) . ')';\n        $initializer->($expr);\n\n        push @result, \"n$i = $expr\";\n        my $n = \"n$i\";\n\n        if ($i == 0 or $i == $#number) {\n            push @result, \"$number[$i] = $n\";\n            $mem = '0';\n        }\n        else {\n            push @result, \"$number[$i] = ($n % 10)\";\n            $mem = \"int($n / 10)\";\n        }\n    }\n\n    return @result;\n}\n\n# 71 * 43\n#say for semiprime_equationization('3053', 2, 2);\n\n# 251 * 197\nsay for semiprime_equationization('49447', 3, 3);\n\n# 37975227936943673922808872755445627854565536638199 * 40094690950920881030683735292761468389214899724061\n#say for semiprime_equationization('1522605027922533360535618378132637429718068114961380688657908494580122963258952897654000350692006139', 50, 50);\n"
  },
  {
    "path": "Math/semiprime_equationization_uncached.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 09 July 2015\n# Website: https://github.com/trizen\n\n# Split a semiprime into a group of equations.\n\nuse 5.010;\nuse strict;\nuse integer;\nuse warnings;\n\nsub semiprime_equationization {\n    my ($semiprime, $xlen, $ylen) = @_;\n\n    $xlen -= 1;\n    $ylen -= 1;\n\n    my @map;\n    my $mem = '0';\n\n    foreach my $j (0 .. $ylen) {\n        foreach my $i (0 .. $xlen) {\n            my $n = '(' . join(' + ', \"(x[$i] * y[$j])\", grep { $_ ne '0' } $mem) . ')';\n\n            if ($i == $xlen) {\n                push @{$map[$j]}, \"($n % 10)\", \"int($n / 10)\";\n                $mem = '0';\n            }\n            else {\n                push @{$map[$j]}, \"($n % 10)\";\n                $mem = \"int($n / 10)\";\n            }\n        }\n\n        my $n = $ylen - $j;\n        if ($n > 0) {\n            push @{$map[$j]}, ((0) x $n);\n        }\n\n        my $m = $ylen - $n;\n        if ($m > 0) {\n            unshift @{$map[$j]}, ((0) x $m);\n        }\n    }\n\n    my @number = reverse split //, $semiprime;\n\n    my @result;\n    my @mrange = (0 .. $#map);\n\n    foreach my $i (0 .. $#number) {\n        my $n = '(' . join(' + ', grep { $_ ne '0' } (map { $map[$_][$i] } @mrange), $mem) . ')';\n\n        if ($i == 0 or $i == $#number) {\n            push @result, \"$number[$i] = $n\";\n            $mem = '0';\n        }\n        else {\n            push @result, \"$number[$i] = ($n % 10)\";\n            $mem = \"int($n / 10)\";\n        }\n    }\n\n    return @result;\n}\n\n# 71 * 43\n#say for semiprime_equationization('3053', 2, 2);\n\n# 251 * 197\nsay for semiprime_equationization('49447', 3, 3);\n\n# 37975227936943673922808872755445627854565536638199 * 40094690950920881030683735292761468389214899724061\n#say for semiprime_equationization('1522605027922533360535618378132637429718068114961380688657908494580122963258952897654000350692006139', 50, 50);\n"
  },
  {
    "path": "Math/sequence_analyzer.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 13 April 2016\n# Edit: 15 May 2021\n# https://github.com/trizen\n\n# Analyze a sequence of numbers and generate a report with the results.\n\n# The sequence file must contain one term per line.\n# Alternatively, the terms can be specified as command-line arguments.\n\nuse 5.014;\nuse strict;\nuse warnings;\n\npackage Sequence::Report {\n\n    use Text::ASCIITable;\n    use ntheory qw(LogarithmicIntegral);\n\n    sub new {\n        my ($class, %opt) = @_;\n        bless \\%opt, $class;\n    }\n\n    sub display {\n        my ($self) = @_;\n\n        my $percent = sub {\n            sprintf('%.4g%%', $_[0] / $self->{count} * 100);\n        };\n\n        my $avg = sub {\n            sprintf('%.2f', $_[0] / $self->{count});\n        };\n\n        my $t = Text::ASCIITable->new();\n        my @columns = ('Label', 'Absolute' . ' ' x 30, 'Percentage' . ' ' x 10);\n        $t->setCols(@columns);\n\n        foreach my $row (\n            ['Terms count', $self->{count}],\n\n            (\n               $self->{odds} || $self->{evens}\n             ? !$self->{odds} || ($self->{odds} && $self->{evens} && $self->{evens} >= $self->{odds})\n                   ? ['Evens', $self->{evens}, $percent->($self->{evens})]\n                   : $self->{odds} ? ['Odds', $self->{odds}, $percent->($self->{odds})]\n                 : ()\n             : ()\n            ),\n\n              ($self->{pos} ? [\"Positives\", $self->{pos}, $percent->($self->{pos})] : ()),\n              ($self->{neg}    ? [\"Negatives\", $self->{neg},    $percent->($self->{neg})]    : ()),\n              ($self->{zeros}  ? [\"Zeros\",     $self->{zeros},  $percent->($self->{zeros})]  : ()),\n              ($self->{primes} ? ['Primes',    $self->{primes}, $percent->($self->{primes})] : ()),\n\n              (\n                $self->{perfect_powers}\n                ? ['Perfect powers', $self->{perfect_powers}, $percent->($self->{perfect_powers})]\n                : ()\n              ),\n\n              (\n                $self->{perfect_squares}\n                ? ['Perfect squares', $self->{perfect_squares}, $percent->($self->{perfect_squares})]\n                : ()\n              ),\n\n              (\n                $self->{duplicates}\n                ? ['Duplicated terms', $self->{duplicates}, $percent->($self->{duplicates})]\n                : ()\n              ),\n\n              (\n                $self->{increasing_consecutive}\n                ? ['Cons. increasing terms',\n                   $self->{increasing_consecutive} + 1,\n                   $percent->($self->{increasing_consecutive} + 1)\n                  ]\n                : ()\n              ),\n\n              (\n                $self->{decreasing_consecutive}\n                ? ['Consecutive decreasing terms',\n                   $self->{decreasing_consecutive} + 1,\n                   $percent->($self->{decreasing_consecutive} + 1)\n                  ]\n                : ()\n              ),\n\n              (\n                $self->{equal_consecutive}\n                ? ['Consecutive equal terms', $self->{equal_consecutive} + 1, $percent->($self->{equal_consecutive} + 1)]\n                : ()\n              ),\n\n              ['Minimum value', $self->{min}], ['Maximum value', $self->{max}],\n\n              (\n                  (ref($self->{divisors_avg}) && $self->{divisors_avg}->is_nan) || !$self->{divisors_avg}\n                ? ()\n                : ['Avg. number of divisors', sprintf('%.2f', $self->{divisors_avg})]\n              ),\n\n              (\n                  (ref($self->{factors_avg}) && $self->{factors_avg}->is_nan) || !$self->{factors_avg}\n                ? ()\n                : ['Avg. number of prime factors', sprintf('%.2f', $self->{factors_avg})]\n              ),\n\n              (\n                $self->{divisor_sum_avg}\n                ? ['Divisor sum average', $self->{divisor_sum_avg}]\n                : ()\n              ),\n\n              (\n                ref($self->{arithmetic_mean}) && !$self->{arithmetic_mean}->is_real\n                ? ()\n                : ['Arithmetic mean', $self->{arithmetic_mean}]\n              ),\n\n              (\n                ref($self->{geometric_mean}) && !$self->{geometric_mean}->is_real\n                ? ()\n                : ['Geometric mean', $self->{geometric_mean}]\n              ),\n\n              (\n                ref($self->{harmonic_mean}) && !$self->{harmonic_mean}->is_real\n                ? ()\n                : ['Harmonic mean', $self->{harmonic_mean}]\n              ),\n\n              (\n                ref($self->{lowest_ratio}) && !$self->{lowest_ratio}->is_real\n                ? ()\n                : ['Lowest consecutive ratio', $self->{lowest_ratio}]\n              ),\n\n              (\n                ref($self->{highest_ratio}) && !$self->{highest_ratio}->is_real\n                ? ()\n                : ['Highest consecutive ratio', $self->{highest_ratio}]\n              ),\n\n              (\n                  exists($self->{ratios_sum})\n                ? ref($self->{ratios_sum}) && !$self->{ratios_sum}->is_real\n                      ? ()\n                      : ['Avg. consecutive ratio', $self->{ratios_sum} / ($self->{count} - 1)]\n                : ()\n              ),\n\n              (\n                ref($self->{lowest_diff}) && !$self->{lowest_diff}->is_real\n                ? ()\n                : ['Lowest consecutive difference', $self->{lowest_diff}]\n              ),\n\n              (\n                ref($self->{highest_diff}) && !$self->{highest_diff}->is_real\n                ? ()\n                : ['Highest consecutive difference', $self->{highest_diff}]\n              ),\n\n              (\n                  exists($self->{avg_diff})\n                ? ref($self->{avg_diff}) && !$self->{avg_diff}->is_real\n                      ? ()\n                      : ['Avg. consecutive difference', $self->{avg_diff}]\n                : ()\n              ),\n          ) {\n            my ($label, $value, $extra) = @$row;\n            $t->addRow($label, sprintf(\"%.15g\", $value), defined($extra) ? $extra : ());\n        }\n\n        $t->alignCol({$columns[1] => 'right'});\n        $t->alignCol({$columns[2] => 'right'});\n\n        print $t;\n\n        say \"\\n=> Summary:\";\n\n        # Number of primes\n        if ($self->{primes}) {\n            my $li_dist = LogarithmicIntegral($self->{count});\n            my $log_dist = $self->{count} > 1 ? ($self->{count} / log($self->{count})) : 0;\n\n            if ($self->{primes} == $self->{count}) {\n                say \"\\tall terms are prime numbers\";\n            }\n            elsif ($self->{primes} >= $li_dist) {\n                if ($self->{primes} / $self->{count} * 100 > 80) {\n                    say \"\\tcontains many primes (>80%)\";\n                }\n                else {\n                    printf(\"\\tcontains about %.2f times more than a random number of primes\\n\", $self->{primes} / $li_dist);\n                }\n            }\n            elsif ($self->{primes} < $li_dist and $self->{primes} > $log_dist) {\n                printf(\"\\tcontains a random number of primes (between %d and %d)\\n\", int($log_dist), int($li_dist));\n            }\n            else {\n                printf(\"\\tcontains about %.2f times less than a random number of primes\\n\", $li_dist / $self->{primes});\n            }\n        }\n        elsif (($self->{evens} or $self->{odds}) and not $self->{neg}) {\n            say \"\\tcontains no primes\";\n        }\n\n        # Odd or even terms\n        if ($self->{evens} and $self->{evens} == $self->{count}) {\n            say \"\\tall terms are even\";\n        }\n        elsif ($self->{odds} and $self->{odds} == $self->{count}) {\n            say \"\\tall terms are odd\";\n        }\n        elsif ($self->{evens} && $self->{odds} and $self->{evens} == $self->{odds}) {\n            say \"\\tequal number of odds and evens\";\n        }\n\n        # Increasing sequence\n        if ($self->{increasing_consecutive} and $self->{increasing_consecutive} == $self->{count} - 1) {\n            say \"\\tall terms are in a strictly increasing order\";\n        }\n\n        # Decreasing sequence\n        if ($self->{decreasing_consecutive} and $self->{decreasing_consecutive} == $self->{count} - 1) {\n            say \"\\tall terms are in a strictly decreasing order\";\n        }\n\n        # Geometric sequence\n        if (    ref($self->{lowest_ratio}) && $self->{lowest_ratio}->is_real\n            and ref($self->{highest_ratio}) && $self->{highest_ratio}->is_real\n            and $self->{lowest_ratio} == $self->{highest_ratio}) {\n            say \"\\tgeometric sequence (ratio = $self->{lowest_ratio})\";\n\n            if ($self->{increasing_consecutive} && $self->{increasing_consecutive} == $self->{count} - 1) {\n                say \"\\tpossible closed-form: \" . (\n                    $self->{lowest_ratio} == 1 ? 'n' : (\n                       $self->{min} == 1\n                       ? \"$self->{lowest_ratio}^(n-1)\"\n                       : (\n                          $self->{min} == $self->{lowest_ratio} ? \"$self->{lowest_ratio}^n\" : (\n                             \"$self->{lowest_ratio}^(n\" . do {\n                                 my $log = $self->{min}->log($self->{lowest_ratio})->sub(1)->round(-30);\n                                 $log->is_zero ? ''\n                                   : (\n                                      $log->is_int\n                                        || length($log->as_rat) < 20\n                                        || length($self->{min}->as_rat) > 20 ? (' ' . $log->sgn . ' ' . $log->abs)\n                                      : (\" + log($self->{min})/log($self->{lowest_ratio}) - 1\")\n                                     );\n                               }\n                               . ')'\n                          )\n                         )\n                    )\n                );\n\n                if ($self->{min} > $self->{lowest_ratio}) {\n                    my $factor = $self->{min} / $self->{lowest_ratio};\n                    say(\n                        \"\\tpossible closed-form: \"\n                          . (\n                             ($factor == 1 ? '' : \"$factor * \")\n                             . (\n                                $self->{lowest_ratio} == 1\n                                ? 'n'\n                                : \"$self->{lowest_ratio}^n\"\n                               )\n                            )\n                       );\n                }\n            }\n        }\n\n        # Arithmetic sequence\n        if (    ref($self->{lowest_diff}) && $self->{lowest_diff}->is_real\n            and ref($self->{highest_diff}) && $self->{highest_diff}->is_real\n            and $self->{lowest_diff} == $self->{highest_diff}) {\n            say \"\\tarithmetic sequence (diff = $self->{lowest_diff})\";\n\n            if ($self->{increasing_consecutive} && $self->{increasing_consecutive} == $self->{count} - 1) {\n                my $min = ($self->{min} - $self->{lowest_diff})->round(-20);\n                say \"\\tpossible closed-form: \"\n                  . (\n                     $self->{lowest_diff} == 0 ? $min\n                     : (\n                        ($self->{lowest_diff} == 1 ? 'n' : \"$self->{lowest_diff}n\")\n                        . (\n                           $min == 0 ? ''\n                           : (' ' . $min->sgn . ' ' . $min->abs)\n                          )\n                       )\n                    );\n            }\n        }\n\n        # Perfect power sequence\n        if ($self->{perfect_squares} && $self->{perfect_squares} == $self->{count}) {\n            say \"\\tsequence of perfect squares\";\n        }\n        elsif (\n               $self->{perfect_powers}\n               and (\n                    $self->{perfect_powers} == $self->{count}\n                    or (    $self->{perfect_squares}\n                        and $self->{perfect_powers} + $self->{perfect_squares} == $self->{count})\n                   )\n          ) {\n            say \"\\tsequence of perfect powers\";\n        }\n\n        $self;\n    }\n}\n\npackage Sequence {\n\n    use Math::AnyNum qw(Inf);\n    use ntheory qw(factor divisors divisor_sum);\n    use List::Util qw(all pairmap);\n\n    sub new {\n        my ($class, %opt) = @_;\n        bless \\%opt, $class;\n    }\n\n    sub analyze {\n        my ($self) = @_;\n\n        my $seq = $self->{sequence};\n\n        my %data = (\n                    geometric_mean => 1,\n                    lowest_ratio   => Inf,\n                    highest_ratio  => -Inf,\n                    lowest_diff    => Inf,\n                    highest_diff   => -Inf,\n                    count          => scalar(@$seq),\n                   );\n\n        $data{count} > 0\n          or die \"ERROR: empty sequence of numbers!\\n\";\n\n        my $min = Inf;\n        my $max = -Inf;\n\n        my $prev;\n\n        my %seen;\n        my $i = 0;\n\n        foreach my $n (@$seq) {\n\n            if ($seen{$n}++) {\n                ++$data{duplicates};\n            }\n\n            my $cmp = $n <=> 0;\n\n            if ($cmp == 0) {\n                ++$data{zeros};\n            }\n            elsif ($cmp > 0) {\n                ++$data{pos};\n            }\n            else {\n                ++$data{neg};\n            }\n\n            $data{arithmetic_mean} += $n / $data{count};\n            $data{geometric_mean} *= $n->root($data{count});\n            $data{harmonic_mean} += $n->inv;\n\n            if ($self->{is_int}) {\n\n                if ($self->{is_pos}) {\n                    if ($n->is_prime) {\n                        ++$data{primes};\n                        $data{factors_avg}     += 1 / $data{count};\n                        $data{divisors_avg}    += 2 / $data{count};\n                        $data{divisor_sum_avg} += ($n + 1) / $data{count};\n                    }\n                    else {\n                        $data{factors_avg}     += factor($n) / $data{count};\n                        $data{divisors_avg}    += divisors($n) / $data{count};\n                        $data{divisor_sum_avg} += divisor_sum($n) / $data{count};\n                    }\n                }\n\n                if ($n->is_square) {\n                    ++$data{perfect_squares};\n                }\n                elsif ($n->is_power) {\n                    ++$data{perfect_powers};\n                }\n\n                if ($n->is_even) {\n                    ++$data{evens};\n                }\n                else {\n                    ++$data{odds};\n                }\n            }\n\n            if ($n < $min) {\n                $min = $n;\n            }\n\n            if ($n > $max) {\n                $max = $n;\n            }\n\n            if (defined($prev)) {\n\n                {\n                    my $diff = $n - $prev;\n                    $data{avg_diff} += $diff / ($data{count} - 1);\n\n                    if ($diff < $data{lowest_diff}) {\n                        $data{lowest_diff} = $diff;\n                    }\n\n                    if ($diff > $data{highest_diff}) {\n                        $data{highest_diff} = $diff;\n                    }\n                }\n\n                {\n                    my $div = $n / $prev;\n\n                    $data{ratios_sum} += $div;\n\n                    if ($div < $data{lowest_ratio}) {\n                        $data{lowest_ratio} = $div;\n                    }\n\n                    if ($div > $data{highest_ratio}) {\n                        $data{highest_ratio} = $div;\n                    }\n                }\n\n                if (defined(my $cmp = $n <=> $prev)) {\n                    if ($cmp > 0) {\n                        ++$data{increasing_consecutive};\n                    }\n                    elsif ($cmp < 0) {\n                        ++$data{decreasing_consecutive};\n                    }\n                    else {\n                        ++$data{equal_consecutive};\n                    }\n                }\n            }\n\n            $prev = $n;\n\n            if (++$i > 500) {\n                while (my ($key, $value) = each %data) {\n                    if (ref($value) eq 'Math::AnyNum') {\n                        $data{$key} = $value->float;\n                    }\n                }\n                $i = 0;\n            }\n        }\n\n        $data{harmonic_mean} = $data{count} / $data{harmonic_mean};\n\n        while (my ($key, $value) = each %data) {\n            if (ref($value) eq 'Math::AnyNum') {\n                $data{$key} = $value->round(-30);\n            }\n        }\n\n        $data{min} = $min;\n        $data{max} = $max;\n\n        $data{equal} = $min == $max;\n\n        Sequence::Report->new(%data);\n    }\n}\n\nuse Getopt::Long qw(GetOptions);\n\nsub usage {\n    print <<\"EOT\";\nusage: $0 [options] [< sequence.txt]\n\noptions:\n    -m  --map=type,type : map the sequence\n    -r  --reverse!      : reverse the sequence\n    -s  --sort!         : sort the sequence\n    -u  --uniq!         : remove duplicated terms\n    -p  --prec=i        : number of decimals of precision\n    -f  --first=i       : read only the first i terms\n    -o  --output=s      : output the sequence into this file\n\nvalid map types:\n    sum     : consecutive sums\n    ratio   : consecutive ratios\n    prod    : consecutive products\n    diff    : consecutive differences\n\n    abs     : take the absolute value\n    int     : take the integer part\n    floor   : take the floor value\n    ceil    : take the ceil value\n    log     : natural logarithm of each term\n    log=x   : base x logarithm of each term\n    div=x   : divide each term by x\n    mul=x   : multiply each term by x\n    add=x   : add x to each term\n    sub=x   : subtract x from each term\n    exp     : exponential of each term (e^k)\n    cos     : cos() of each term\n    sin     : sin() of each term\n    inv     : inverse value (1/k)\n    sqr     : square each term (k^2)\n    sqrt    : take the square root of each term (k^(1/2))\n    pow     : rise each term to the nth power (k^n)\n    pow=x   : rise each term to the i power (k^x)\n    root    : take the nth root of each term (k^(1/n))\n    root=x  : take the k root of each term (k^(1/x))\n\n    padd    : consecutive pair sum\n    pdiv    : consecutive pair ratio\n    pmul    : consecutive pair product\n    psub    : consecutive pair difference\n\nexample:\n    $0 -u -m root=5,floor,sum < FibonacciSeq.txt\nEOT\n    exit;\n}\n\nmy $map     = '';\nmy $reverse = 0;\nmy $sort    = 0;\nmy $uniq    = 0;\nmy $prec    = 32;\nmy $first   = undef;\nmy $output  = undef;\n\nGetOptions(\n           'm|map=s'    => \\$map,\n           'r|reverse!' => \\$reverse,\n           's|sort!'    => \\$sort,\n           'u|uniq!'    => \\$uniq,\n           'p|prec=i'   => \\$prec,\n           'f|first=i'  => \\$first,\n           'o|output=s' => \\$output,\n           'h|help'     => \\&usage,\n          )\n  or die \"Error in command-line arguments\";\n\nlocal $Math::AnyNum::PREC = 4 * $prec;\n\nmy @numbers;\n\nmy $value_re = qr/(?:=([-+]?\\d+(?:\\.\\d+)?+)\\b)?/;\nmy $trans_re = qr/\\b(log|sqrt|root|pow|sqr|abs|exp|int|floor|ceil|inv|add|mul|div|sub|cos|sin)\\b$value_re/o;\n\nmy @terms;\n\nif (@ARGV) {\n    @terms = (map { Math::AnyNum->new($_) } grep { /[0-9]/ } map { split(' ') } map { split(/\\s*,\\s*/) } @ARGV)\n}\nelse {\n    while (<>) {\n\n        my $num = (split(' '))[-1];\n\n        if ($num =~ /[0-9]/) {\n            push @terms, Math::AnyNum->new($num);\n        }\n    }\n}\n\nforeach my $num (@terms) {\n\n    push @numbers, $num;\n\n    while ($map =~ /$trans_re/go) {\n        if ($1 eq 'log') {\n            $numbers[-1] = (defined($2)\n              ? $numbers[-1]->log($2)\n              : $numbers[-1]->log);\n        }\n        elsif ($1 eq 'sqrt') {\n            $numbers[-1] = $numbers[-1]->sqrt;\n        }\n        elsif ($1 eq 'root') {\n            $numbers[-1] = (defined($2)\n              ? $numbers[-1]->root($2)\n              : $numbers[-1]->root($.));\n        }\n        elsif ($1 eq 'pow') {\n            $numbers[-1] = (defined($2)\n              ? $numbers[-1]->pow($2)\n              : $numbers[-1]->pow($.));\n        }\n        elsif ($1 eq 'sqr') {\n            $numbers[-1] = $numbers[-1]->sqr;\n        }\n        elsif ($1 eq 'inv') {\n            $numbers[-1] = $numbers[-1]->inv;\n        }\n        elsif ($1 eq 'abs') {\n            $numbers[-1] = $numbers[-1]->abs;\n        }\n        elsif ($1 eq 'int') {\n            $numbers[-1] = $numbers[-1]->int;\n        }\n        elsif ($1 eq 'cos') {\n            $numbers[-1] = $numbers[-1]->cos;\n        }\n        elsif ($1 eq 'sin') {\n            $numbers[-1] = $numbers[-1]->sin;\n        }\n        elsif ($1 eq 'ceil') {\n            $numbers[-1] = $numbers[-1]->ceil;\n        }\n        elsif ($1 eq 'floor') {\n            $numbers[-1] = $numbers[-1]->floor;\n        }\n        elsif ($1 eq 'exp') {\n            $numbers[-1]->bexp;\n        }\n        elsif ($1 eq 'add') {\n            $numbers[-1] = (defined($2)\n              ? $numbers[-1]->add($2)\n              : $numbers[-1]->add($.));\n        }\n        elsif ($1 eq 'sub') {\n            $numbers[-1] = (defined($2)\n              ? $numbers[-1]->sub($2)\n              : $numbers[-1]->sub($.));\n        }\n        elsif ($1 eq 'mul') {\n            $numbers[-1] = (defined($2)\n              ? $numbers[-1]->mul($2)\n              : $numbers[-1]->mul($.));\n        }\n        elsif ($1 eq 'div') {\n            $numbers[-1] = (defined($2)\n              ? $numbers[-1]->div($2)\n              : $numbers[-1]->div($.));\n        }\n        else {\n            die \"ERROR: unknown map type: `$1`\";\n        }\n    }\n\n    if (defined($first) and $. >= $first) {\n        last;\n    }\n}\n\nif ($uniq) {\n    my %seen;\n    @numbers = grep { !$seen{$_->as_rat}++ } @numbers;\n}\n\nif ($sort) {\n    @numbers = sort { $a <=> $b } @numbers;\n}\n\nif ($reverse) {\n    @numbers = reverse(@numbers);\n}\n\nmy $consecutive_re = qr/\\b(ratio|diff|sum|prod)\\b/;\n\nif ($map =~ /$consecutive_re/o) {\n\n    my @new;\n    my $prev = shift @numbers;\n\n    foreach my $num (@numbers) {\n        while ($map =~ /$consecutive_re/go) {\n            if ($1 eq 'ratio') {\n                $prev /= $num;\n            }\n            elsif ($1 eq 'prod') {\n                $prev *= $num;\n            }\n            elsif ($1 eq 'diff') {\n                $prev -= $num;\n            }\n            elsif ($1 eq 'sum') {\n                $prev += $num;\n            }\n            else {\n                die \"ERROR: unknown map type: `$1`\";\n            }\n        }\n        push @new, $prev;\n    }\n\n    @numbers = @new;\n}\n\nmy $pair_re = qr/\\b(pdiv|psub|padd|pmul)\\b/;\n\nif ($map =~ /$pair_re/o) {\n\n    my @new;\n    my $prev;\n\n    foreach my $num (reverse(@numbers)) {\n        if (defined($prev)) {\n            while ($map =~ /$pair_re/go) {\n                if ($1 eq 'pdiv') {\n                    $prev /= $num;\n                }\n                elsif ($1 eq 'pmul') {\n                    $prev *= $num;\n                }\n                elsif ($1 eq 'psub') {\n                    $prev -= $num;\n                }\n                elsif ($1 eq 'padd') {\n                    $prev += $num;\n                }\n                else {\n                    die \"ERROR: unknown map type: `$1`\";\n                }\n            }\n            unshift @new, $prev;\n        }\n        $prev = $num;\n    }\n\n    if ($uniq) {\n        my %seen;\n        @new = grep { !$seen{$_->as_rat}++ } @new;\n    }\n\n    if ($sort) {\n        @new = sort { $a <=> $b } @new;\n    }\n\n    @numbers = @new;\n}\n\nuse List::Util qw(all any min);\n\n# Display the first 10 terms of the sequence\nsay \"=> First 10 terms:\";\nsay for @numbers[0 .. min(9, $#numbers)];\nsay '';\n\n# Output the sequence into a file\nif (defined($output)) {\n    open my $fh, '>', $output;\n    local $, = \"\\n\";\n    say {$fh} @numbers;\n}\n\n# Generate a report for the sequence\nmy $report = Sequence->new(\n                           sequence => \\@numbers,\n                           is_int   => (all { $_->is_int } @numbers),\n                           is_pos   => !(any { $_->is_neg } @numbers),\n                          )->analyze;\n\n# Display the report\n$report->display;\n\n__END__\n\nFirst 10 terms:\n6\n18\n54\n162\n486\n1458\n4374\n13122\n39366\n118098\n\n.------------------------------------------------------------------------------------------------.\n| Label                          | Absolute                               | Percentage           |\n+--------------------------------+----------------------------------------+----------------------+\n| Terms count                    |                                    100 |                      |\n| Evens                          |                                    100 |                 100% |\n| Positives                      |                                    100 |                 100% |\n| Cons. increasing terms         |                                    100 |                 100% |\n| Minimum value                  |                                      6 |                      |\n| Maximum value                  |                   1.03075504146402e+48 |                      |\n| Avg. number of prime factors   |                                   51.5 |                      |\n| Divisor sum average            |                   3.47879826494108e+46 |                      |\n| Arithmetic mean                |                   1.54613256219603e+46 |                      |\n| Geometric mean                 |                   2.48687157866749e+24 |                      |\n| Harmonic mean                  |                                    400 |                      |\n| Lowest consecutive ratio       |                                      3 |                      |\n| Highest consecutive ratio      |                                      3 |                      |\n| Avg. consecutive ratio         |                                      3 |                      |\n| Lowest consecutive difference  |                                     12 |                      |\n| Highest consecutive difference |                   6.87170027642682e+47 |                      |\n| Avg. consecutive difference    |                   1.04116670854952e+46 |                      |\n'--------------------------------+----------------------------------------+----------------------'\n\n=> Summary:\n    contains no primes\n    all terms are even\n    all terms are in a strictly increasing order\n    geometric sequence (ratio = 3)\n    possible closed-form: 3^(n + log(6)/log(3) - 1)\n    possible closed-form: 2 * 3^n\n"
  },
  {
    "path": "Math/sequence_closed_form.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 15 April 2016\n# Edit: 15 May 2021\n# https://github.com/trizen\n\n# Analyze a sequence of numbers and find a closed-form expression.\n\n# Unfinished work...\n# Use the script \"sequence_analyzer.pl\" instead.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\npackage Sequence::ClosedForm {\n\n    use Math::AnyNum qw(Inf);\n\n    sub new {\n        my ($class, %opt) = @_;\n        bless \\%opt, $class;\n    }\n\n    sub sub_n {\n        my $n = 0;\n        sub {\n            $_[0] - ++$n;\n        };\n    }\n\n    sub add_n {\n        my $n = 0;\n        sub {\n            $_[0] + ++$n;\n        };\n    }\n\n    sub mul_n {\n        my $n = 1;\n        sub {\n            $_[0] * ++$n;\n        };\n    }\n\n    sub div_n {\n        my $n = 1;\n        sub {\n            $_[0] / ++$n;\n        };\n    }\n\n    sub sub_constant {\n        my (undef, $c) = @_;\n        sub {\n            $_[0] - $c;\n        };\n    }\n\n    sub div_constant {\n        my (undef, $c) = @_;\n        sub {\n            $_[0] / $c;\n        };\n    }\n\n    sub add_constant {\n        my (undef, $c) = @_;\n        sub {\n            $_[0] + $c;\n        };\n    }\n\n    sub add_all {\n        my $sum = 0;\n        sub {\n            $sum += $_[0];\n            $sum;\n        };\n    }\n\n    sub mul_all {\n        my $prod = 1;\n        sub {\n            $prod *= $_[0];\n            $prod;\n        };\n    }\n\n    sub sub_consecutive {\n        my $prev;\n        sub {\n            my ($term) = @_;\n            if (defined($prev)) {\n                $term = $term - $prev;\n            }\n            $prev = $_[0];\n            $term;\n        };\n    }\n\n    sub add_consecutive {\n        my $prev;\n        sub {\n            my ($term) = @_;\n            if (defined($prev)) {\n                $term = $term + $prev;\n            }\n            $prev = $_[0];\n            $term;\n        };\n    }\n\n    sub div_consecutive {\n        my $prev;\n        sub {\n            my ($term) = @_;\n            if (defined($prev)) {\n                $term = $term / $prev;\n            }\n            $prev = $_[0];\n            $term;\n        };\n    }\n\n    sub find_closed_form {\n        my ($self, $seq) = @_;\n\n        my %data = (\n            diff_min => Inf,\n            diff_max => -Inf,\n            diff_avg => 0,\n\n            ratio_min => Inf,\n            ratio_max => -Inf,\n            ratio_avg => 0,\n\n            min => Inf,\n            max => -Inf,\n                   );\n\n        my $count = @$seq - 1;\n        return if $count <= 0;\n\n        my $prev;\n        foreach my $term (@{$seq}) {\n\n            if ($term < $data{min}) {\n                $data{min} = $term;\n            }\n\n            if ($term > $data{max}) {\n                $data{max} = $term;\n            }\n\n            if (defined $prev) {\n                my $diff = $term - $prev;\n\n                if ($diff < $data{diff_min}) {\n                    $data{diff_min} = $diff;\n                }\n\n                if ($diff > $data{diff_max}) {\n                    $data{diff_max} = $diff;\n                }\n\n                $data{diff_avg} += $diff / $count;\n\n                my $ratio = $term / $prev;\n\n                if ($ratio < $data{ratio_min}) {\n                    $data{ratio_min} = $ratio;\n                }\n\n                if ($ratio > $data{ratio_max}) {\n                    $data{ratio_max} = $ratio;\n                }\n\n                $data{ratio_avg} += $ratio;\n\n            }\n\n            $prev = $term;\n        }\n\n        $data{ratio_avg} /= $count;\n\n        my @closed_forms;\n\n        if ($data{diff_avg} == $data{diff_max} and $data{diff_max} == $data{diff_min}) {\n            my $min = ($data{min} - $data{diff_min})->round(-20);\n            push @closed_forms,\n              scalar {\n                      factor => $data{diff_min},\n                      offset => $min,\n                      type   => 'arithmetic',\n                     };\n        }\n\n        if ($data{ratio_avg} == $data{ratio_max} and $data{ratio_max} == $data{ratio_min}) {\n            my $factor = $data{min} / $data{ratio_min};\n            push @closed_forms,\n              scalar {\n                      factor => $factor,\n                      base   => $data{ratio_min},\n                      type   => 'geometric',\n                     };\n        }\n\n        #foreach my $key (sort keys %data) {\n        #    printf(\"%9s => %s\\n\", $key, $data{$key});\n        #}\n        #print \"\\n\";\n\n        return @closed_forms;\n    }\n}\n\nuse Math::AnyNum;\nuse List::Util qw(first);\n\nmy $seq       = Sequence::ClosedForm->new();\nmy @constants = (1 .. 5);                      #, #exp(1), atan2(0, -'inf'));\n\nmy @rules = (\n\n    #['sub_consecutive', 'add_n'], # 'add_n'],\n    #['add_constant', 'sub_consecutive'],\n    ['sub_constant', 'sub_consecutive'],\n    ['sub_constant', 'div_constant'],\n    ['sub_constant'],\n\n    #['add_constant', 'div_consecutive'],\n    ['sub_constant', 'add_n',],\n    ['sub_constant', 'div_consecutive', 'sub_constant'],\n\n    #['sub_constant'],\n    #['sub_constant', 'div_consecutive',],\n    ['sub_constant', 'div_consecutive'],\n\n    #['div_consecutive', 'sub_constant'],\n\n    # ['sub_constant', 'sub_consecutive'],\n\n    #['sub_constant'],\n    #['add_n', 'div_consecutive',],\n    #['div_consecutive',],\n);\n\nsub make_constant_obj {\n    my ($method) = @_;\n\n    my %cache;\n\n    my %state = (\n        i    => 0,\n        done => 0,\n\n        code => sub {\n            my ($self, $n) = @_;\n            my $i = $self->{i} - 1;\n            my $sub = ($cache{$i} //= $seq->$method($constants[$i]));\n            $sub->($n);\n        }\n    );\n\n    bless \\%state, 'Sequence::Constant';\n}\n\nsub generate_actions {\n    map { /_constant\\z/ ? [$_, make_constant_obj($_)] : [$_, $seq->$_] } @_;\n}\n\nmy @numbers = (map { Math::AnyNum->new($_) } 1 .. 9);\n\n#my @seq = map { 3**$_ + 2} @numbers;\n#my @seq = map { 3 * $_  } @numbers;\n#my @seq = map { $_ * ($_ + 1) / 2 + 1 } @numbers;\nmy @seq = map { $_->factorial + 2 } @numbers;\n\nsay \"\\nseq: @seq\\n\";\n\nmy %closed_forms = (\n    sub_consecutive => sub {\n        my ($n, $data) = @_;\n\n        #\"($data->{factor}*$n + $data->{offset})*($data->{factor}*$n + $data->{offset} + 1)/2\";\n        #\"($n * ($n+1) / 2)\";\n\n        $data->{type} eq 'arithmetic'\n          ? \"($n * ($n+1) / 2)\"\n          : \"($data->{base}**$n)\";\n    },\n    add_n => sub {\n        my ($n, $data) = @_;\n\n        #\"(2 * ($n) / $data->{factor})\";\n        #\"($n / (2 * $data->{factor}))\";\n        #\"($n - 1)\";\n\n        \"($n * \" . ($data->{factor} - 1) . \" / $data->{factor})\";\n    },\n    div_consecutive => sub {\n        my ($n) = @_;\n        \"($n!)\";\n    },\n    add_constant => sub {\n        my ($n, $data, $const) = @_;\n\n        $data->{type} eq 'arithmetic'\n          ? \"($data->{factor}*($n-$constants[$const->{i}-1+$data->{offset}]))\"\n          : die \"geometric sequences are not supported, yet!\";    # TODO: implement it\n    },\n    sub_constant => sub {\n        my ($n, $data, $const) = @_;\n        $data->{type} eq 'arithmetic'\n          ? \"($data->{factor}*($n+$constants[$const->{i}-1]+$data->{offset}))\"\n          : \"($constants[$const->{i}-1] + $n)\";                   # wrong\n    },\n    div_constant => sub {\n        my ($n, $data, $const) = @_;\n        $data->{type} eq 'geometric'\n          ? \"($constants[$const->{i}-1] * $data->{factor} * $data->{base}**$n)\"\n          : \"($data->{factor} * $n)\";                             # wrong\n    },\n);\n\nsub fill_closed_form {\n    my ($cf, $actions) = @_;\n\n    my $result = 'n';\n    foreach my $action (reverse @$actions) {\n        my ($name, $obj) = @$action;\n\n        #$report .= \"name: $name\" . (ref($obj) eq 'Sequence::Constant' ? (' (' . $constants[$obj->{i}-1] . ')') : '') . \"\\n\";\n        if (not exists($closed_forms{$name})) {\n            warn \"No closed-form for rule: $name\\n\";\n            next;\n        }\n        $result = $closed_forms{$name}($result, $cf, $obj);\n    }\n\n    $result;\n\n    #\"$result / $cf->{factor} + $cf->{offset}\";\n}\n\nsay '-' x 80;\n\nmy %seen;\n\nRULE: foreach my $rule (@rules) {\n    my @actions   = generate_actions(@$rule);\n    my @const_pos = grep { $rule->[$_] =~ /_constant\\z/ } 0 .. $#{$rule};\n    my $has_const = !!@const_pos;\n\n  WHILE: while (1) {\n\n        foreach my $group (grep { $_->[0] !~ /_constant\\z/ } @actions) {\n            my $method = $group->[0];\n            $group->[1] = $seq->$method;\n        }\n\n        my @sequence;\n\n        my $stop = $has_const;\n        foreach my $pos (@const_pos) {\n            my $constant = $actions[$pos][1];\n\n            if ($constant->{done}) {\n                if ($constant->{i} >= $#constants) {\n                    $constant->{i} = 0;\n                }\n                else {\n                    $constant->{i}++;\n                }\n            }\n            else {\n                if ($constant->{i} >= $#constants) {\n                    $constant->{i}    = 0;\n                    $constant->{done} = 1;\n                }\n                else {\n                    $constant->{i}++;\n                }\n\n                $stop = 0;\n                last;\n            }\n        }\n\n        last if $stop;\n\n        foreach my $term (@seq) {\n            my $result = $term;\n\n            foreach my $group (@actions) {\n                my $action = $group->[1];\n                if (ref($action) eq 'Sequence::Constant') {\n                    $result = $action->{code}($action, $result);\n                }\n                else {\n                    $result = $action->($result);\n                }\n            }\n\n            next WHILE if ($result <= 0 or not $result->is_real);\n            push @sequence, $result;\n        }\n\n        if ($sequence[0] >= $sequence[1]) {\n            $has_const || last;\n            next;\n        }\n\n        next if $seen{join(';', map { $_->as_rat } @sequence)}++;\n\n        say \"try: @sequence\";\n        my @closed_forms = $seq->find_closed_form(\\@sequence);\n\n        if (@closed_forms) {\n            say \"new: @sequence\\n\";\n            foreach my $cf (@closed_forms) {\n                if ($cf->{type} eq 'geometric') {\n                    say \"type: $cf->{type}\";\n                    say \"base: $cf->{base}\";\n                    say \"fact: $cf->{factor}\";\n                }\n                elsif ($cf->{type} eq 'arithmetic') {\n                    say \"type: $cf->{type}\";\n                    say \"fact: $cf->{factor}\";\n                    say \"offs: $cf->{offset}\";\n                }\n                foreach my $action (@actions) {\n                    my ($name, $obj) = @$action;\n                    say \"name: $name\" . (ref($obj) eq 'Sequence::Constant' ? \" (constant: $constants[$obj->{i}-1])\" : '');\n                }\n                my $filled = fill_closed_form($cf, \\@actions);\n                say \"\\n=> Possible closed-form: $filled\";\n            }\n            say '-' x 80;\n        }\n\n        $has_const || last;\n    }\n}\n"
  },
  {
    "path": "Math/sequence_polynomial_closed_form.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 04 January 2019\n# https://github.com/trizen\n\n# Find a closed-form polynomial to a given sequence of numbers.\n\n# See also:\n#   https://www.youtube.com/watch?v=gur16QsZ0r4\n#   https://en.wikipedia.org/wiki/Polynomial_interpolation\n#   https://en.wikipedia.org/wiki/Vandermonde_matrix\n\nuse 5.020;\nuse warnings;\n\nuse Math::MatrixLUP;\nuse Math::AnyNum qw(ipow sum);\n\nuse List::Util qw(all);\nuse experimental qw(signatures);\n\nsub find_poly_degree(@seq) {\n    for (my $c = 1 ; ; ++$c) {\n        @seq = map { $seq[$_ + 1] - $seq[$_] } 0 .. $#seq - 1;\n        return $c if all { $_ == 0 } @seq;\n    }\n}\n\nsub eval_poly ($S, $x) {\n    sum(map { ($S->[$_] == 0) ? 0 : ($S->[$_] * ipow($x, $_)) } 0 .. $#{$S});\n}\n\n# An arbitrary sequence of numbers\nmy @seq = (\n           @ARGV\n           ? (map { Math::AnyNum->new($_) } grep { /[0-9]/ } map { split(' ') } map { split(/\\s*,\\s*/) } @ARGV)\n           : (0, 1, 17, 98, 354, 979, 2275, 4676)\n          );\n\n# Find the lowest polygonal degree to express the sequence\nmy $c = find_poly_degree(@seq);\n\n# Create a new cXc Vandermonde matrix\nmy $A = Math::MatrixLUP->build($c, sub ($n, $k) { ipow($n, $k) });\n\n# Find the polygonal coefficients\nmy $S = $A->solve([@seq[0 .. $c - 1]]);\n\n# Stringify the polynomial\nmy $P = join(' + ', map { ($S->[$_] == 0) ? () : \"($S->[$_] * x^$_)\" } 0 .. $#{$S});\n\nif ($c == scalar(@seq)) {\n    say \"\\n*** WARNING: the polynomial found may not be a closed-form to this sequence! ***\\n\";\n}\n\nsay \"Coefficients : [\", join(', ', @$S), \"]\";\nsay \"Polynomial   : $P\";\nsay \"Next 5 terms : [\", join(', ', map { eval_poly($S, $_) } scalar(@seq) .. scalar(@seq) + 4), \"]\";\n\n__END__\nCoefficients : [0, -1/30, 0, 1/3, 1/2, 1/5]\nPolynomial   : (-1/30 * x^1) + (1/3 * x^3) + (1/2 * x^4) + (1/5 * x^5)\nNext 5 terms : [8772, 15333, 25333, 39974, 60710]\n"
  },
  {
    "path": "Math/sieve_of_eratosthenes.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 18 May 2017\n# https://github.com/trizen\n\n# A simple implementation of the sieve of Eratosthenes for prime numbers.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub sieve_primes {\n    my ($n) = @_;\n\n    my @composite;\n    foreach my $i (2 .. CORE::sqrt($n)) {\n        if (!$composite[$i]) {\n            for (my $j = $i**2 ; $j <= $n ; $j += $i) {\n                $composite[$j] = 1;\n            }\n        }\n    }\n\n    my @primes;\n    foreach my $p (2 .. $n) {\n        $composite[$p] // push(@primes, $p);\n    }\n\n    return @primes;\n}\n\nmy $n = shift(@ARGV) // 100;\nmy @primes = sieve_primes($n);\nsay join(' ', @primes);\nsay \"PI($n) = \", scalar(@primes);\n"
  },
  {
    "path": "Math/sigma0_of_factorial.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 25 July 2017\n# https://github.com/trizen\n\n# An efficient algorithm for computing sigma0(n!).\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(forprimes todigits vecsum);\n\nsub factorial_power ($n, $p) {\n    ($n - vecsum(todigits($n, $p))) / ($p - 1);\n}\n\nsub sigma0_of_factorial {\n    my ($n) = @_;\n\n    my $sigma0 = 1;\n\n    forprimes {\n        $sigma0 *= 1 + factorial_power($n, $_);\n    } $n;\n\n    return $sigma0;\n}\n\nsay sigma0_of_factorial(10);     # 270\nsay sigma0_of_factorial(100);    # 39001250856960000\n"
  },
  {
    "path": "Math/sigma_function.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 18 August 2017\n# https://github.com/trizen\n\n# Efficient implementation of the `sigma_k(n)` function, where k > 0.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(factor_exp);\n\nsub sigma {\n    my ($n, $k) = @_;\n\n    my $sigma = 1;\n\n    foreach my $p (factor_exp($n)) {\n        $sigma *= (($p->[0]**($k * ($p->[1] + 1)) - 1) / ($p->[0]**$k - 1));\n    }\n\n    return $sigma;\n}\n\nsay sigma(10,      1);    #=> 18\nsay sigma(100,     1);    #=> 217\nsay sigma(3628800, 2);    #=> 20993420690550\n"
  },
  {
    "path": "Math/sigma_of_factorial.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 25 July 2017\n# https://github.com/trizen\n\n# An efficient algorithm for computing sigma_k(n!), where k > 0.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(forprimes vecsum todigits);\n\nsub factorial_power ($n, $p) {\n    ($n - vecsum(todigits($n, $p))) / ($p - 1);\n}\n\nsub sigma_of_factorial {\n    my ($n, $a) = @_;\n\n    my $sigma = 1;\n\n    forprimes {\n        my $p = $_;\n        my $k = factorial_power($n, $p);\n        $sigma *= (($p**($a * ($k + 1)) - 1) / ($p**$a - 1));\n    } $n;\n\n    return $sigma;\n}\n\nsay sigma_of_factorial(10, 1);    # sigma_1(10!) = 15334088\nsay sigma_of_factorial(10, 2);    # sigma_2(10!) = 20993420690550\nsay sigma_of_factorial( 8, 3);    # sigma_3( 8!) = 78640578066960\n"
  },
  {
    "path": "Math/sigma_of_product_of_binomials.pl",
    "content": "#!/usr/bin/perl\n\n# Formula for computing the sum of divisors of the product of binomials.\n\n# Using the identities:\n#   Product_{k=0..n} binomial(n, k) = Product_{k=1..n} k^(2*k - n - 1)\n#                                   = hyperfactorial(n)/superfactorial(n)\n\n# and the fact that the sigma function is multiplicative with:\n#   sigma_m(p^k) = (p^(m*(k+1)) - 1)/(p^m - 1)\n\n# See also:\n#   https://oeis.org/A001142\n#   https://oeis.org/A323444\n\n# Paper:\n#   Jeffrey C. Lagarias, Harsh Mehta\n#   Products of binomial coefficients and unreduced Farey fractions\n#   https://arxiv.org/abs/1409.4145\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(prod ipow);\nuse experimental qw(signatures);\nuse ntheory qw(primes todigits vecsum);\n\nmy @cache;\n\nsub sum_of_digits ($n, $p) {\n    return 0 if ($n <= 0);\n    $cache[$n][$p] //= vecsum(todigits($n - 1, $p)) + sum_of_digits($n - 1, $p);\n}\n\nsub power_of_product_of_binomials ($n, $p) {\n    (2 * sum_of_digits($n, $p) - ($n - 1) * vecsum(todigits($n, $p))) / ($p - 1);\n}\n\nsub sigma_of_binomial_product ($n, $m = 1) {\n    prod(\n        map {\n            my $p = $_;\n            my $k = power_of_product_of_binomials($n, $p);\n            (ipow($p, $m * ($k + 1)) - 1) / (ipow($p, $m) - 1);\n        } @{primes($n)}\n    );\n}\n\nsay sigma_of_binomial_product(10);    #=> 141699428035793200\nsay sigma_of_binomial_product(10, 2); #=> 1675051201226374788235139281367100\n"
  },
  {
    "path": "Math/sigma_p_adic.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 14 November 2016\n# Website: https://github.com/trizen\n\n# An interesting function that computes the sum of\n# divisors (excluding the trivial divisors 1 and n),\n# each divisor raised to its p-adic valuation ν_d(n!).\n\n# For prime numbers, the value of `sigma_p_adic(p)` is 0.\n\n# See also:\n#   https://en.wikipedia.org/wiki/P-adic_order\n#   https://en.wikipedia.org/wiki/Legendre%27s_formula\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(divisors forcomposites todigits vecsum);\n\nsub factorial_power ($n, $p) {\n    ($n - vecsum(todigits($n, $p))) / ($p - 1);\n}\n\nsub sigma_p_adic ($n) {\n\n    my @d = divisors($n);\n\n    shift @d;    # remove the first divisor (which is: 1)\n    pop @d;      # remove the last  divisor (which is: n)\n\n    my $s = 0;\n    foreach my $d (@d) {\n        $s += $d**factorial_power($n, $d);\n    }\n\n    return $s;\n}\n\nforcomposites {\n    say $_, \"\\t\", sigma_p_adic($_);\n} 30;\n\n__END__\n4       8\n6       25\n8       144\n9       81\n10      281\n12      1367\n14      2097\n15      854\n16      33856\n18      72394\n20      266965\n21      20026\n22      524409\n24      4271689\n25      15625\n26      8388777\n27      1595052\n28      33622565\n30      71978959\n"
  },
  {
    "path": "Math/siqs_factorization.pl",
    "content": "#!/usr/bin/perl\n\n=begin\n\nThis script factorizes a natural number given as a command line\nparameter into its prime factors. It first attempts to use trial\ndivision to find very small factors, then uses other special-purpose\nfactorization methods to find slightly larger factors. If any large\nfactors remain, it uses the Self-Initializing Quadratic Sieve (SIQS) [2]\nto factorize those.\n\n[2] Contini, Scott Patrick. 'Factoring integers with the self-\n    initializing quadratic sieve.' (1997).\n\n=cut\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\nuse POSIX        qw(ULONG_MAX);\nuse experimental qw(signatures);\n\nuse ntheory qw(\n  urandomm valuation sqrtmod invmod random_prime factor_exp vecmin\n  is_square divisors todigits primes prime_iterator\n);\n\nuse Math::Prime::Util::GMP qw(\n  is_power powmod vecprod sqrtint rootint logint is_prime\n  gcd sieve_primes consecutive_integer_lcm lucas_sequence\n);\n\nmy $ZERO = Math::GMPz->new(0);\nmy $ONE  = Math::GMPz->new(1);\n\nlocal $| = 1;\n\n# Tuning parameters\nuse constant {\n              MASK_LIMIT                => 200,         # show Cn if n > MASK_LIMIT, where n ~ log_10(N)\n              LOOK_FOR_SMALL_FACTORS    => 1,\n              TRIAL_DIVISION_LIMIT      => 1_000_000,\n              PHI_FINDER_ITERATIONS     => 100_000,\n              FERMAT_ITERATIONS         => 100_000,\n              NEAR_POWER_ITERATIONS     => 1_000,\n              PELL_ITERATIONS           => 50_000,\n              FLT_ITERATIONS            => 200_000,\n              HOLF_ITERATIONS           => 100_000,\n              MBE_ITERATIONS            => 100,\n              MILLER_RABIN_ITERATIONS   => 100,\n              LUCAS_MILLER_ITERATIONS   => 50,\n              SIQS_TRIAL_DIVISION_EPS   => 25,\n              SIQS_MIN_PRIME_POLYNOMIAL => 400,\n              SIQS_MAX_PRIME_POLYNOMIAL => 4000,\n             };\n\nmy @small_primes = sieve_primes(2, TRIAL_DIVISION_LIMIT);\n\npackage Polynomial {\n\n    sub new ($class, $coeff, $A = undef, $B = undef) {\n        bless {\n               a     => $A,\n               b     => $B,\n               coeff => $coeff,\n              }, $class;\n    }\n\n    sub eval ($self, $x) {\n        my $res = $ZERO;\n\n        foreach my $k (@{$self->{coeff}}) {\n            $res *= $x;\n            $res += $k;\n        }\n\n        return $res;\n    }\n}\n\npackage FactorBasePrime {\n\n    sub new ($class, $p, $t, $lp) {\n        bless {\n               p     => $p,\n               soln1 => undef,\n               soln2 => undef,\n               t     => $t,\n               lp    => $lp,\n               ainv  => undef,\n              }, $class;\n    }\n}\n\nsub siqs_factor_base_primes ($n, $nf) {\n    my @factor_base;\n\n    foreach my $p (@small_primes) {\n        my $t  = sqrtmod($n, $p) // next;\n        my $lp = sprintf('%0.f', log($p) / log(2));\n        push @factor_base, FactorBasePrime->new($p, $t, $lp);\n\n        if (scalar(@factor_base) >= $nf) {\n            last;\n        }\n    }\n\n    return \\@factor_base;\n}\n\nsub siqs_create_poly ($A, $B, $n, $factor_base, $first) {\n\n    my $B_orig = $B;\n\n    if (($B << 1) > $A) {\n        $B = $A - $B;\n    }\n\n    # 0 < $B                   or die 'error';\n    # 2 * $B <= $A             or die 'error';\n    # ($B * $B - $n) % $A == 0 or die 'error';\n\n    my $g = Polynomial->new([$A * $A, ($A * $B) << 1, $B * $B - $n], $A, $B_orig);\n    my $h = Polynomial->new([$A, $B]);\n\n    foreach my $fb (@$factor_base) {\n\n        next if Math::GMPz::Rmpz_divisible_ui_p($A, $fb->{p});\n\n#<<<\n        $fb->{ainv}  = int(invmod($A, $fb->{p}))                         if $first;\n        $fb->{soln1} = int(($fb->{ainv} * ( $fb->{t} - $B)) % $fb->{p});\n        $fb->{soln2} = int(($fb->{ainv} * (-$fb->{t} - $B)) % $fb->{p});\n#>>>\n\n    }\n\n    return ($g, $h);\n}\n\nsub siqs_find_first_poly ($n, $m, $factor_base) {\n    my $p_min_i;\n    my $p_max_i;\n\n    foreach my $i (0 .. $#{$factor_base}) {\n        my $fb = $factor_base->[$i];\n        if (not defined($p_min_i) and $fb->{p} >= SIQS_MIN_PRIME_POLYNOMIAL) {\n            $p_min_i = $i;\n        }\n        if (not defined($p_max_i) and $fb->{p} > SIQS_MAX_PRIME_POLYNOMIAL) {\n            $p_max_i = $i - 1;\n            last;\n        }\n    }\n\n    # The following may happen if the factor base is small\n    if (not defined($p_max_i)) {\n        $p_max_i = $#{$factor_base};\n    }\n\n    if (not defined($p_min_i)) {\n        $p_min_i = 5;\n    }\n\n    if ($p_max_i - $p_min_i < 20) {\n        $p_min_i = vecmin($p_min_i, 5);\n    }\n\n    my $target0 = (log(\"$n\") + log(2)) / 2 - log(\"$m\");\n    my $target1 = $target0 - log(($factor_base->[$p_min_i]{p} + $factor_base->[$p_max_i]{p}) / 2) / 2;\n\n    # find q such that the product of factor_base[q_i] is approximately\n    # sqrt(2 * n) / m; try a few different sets to find a good one\n    my ($best_q, $best_a, $best_ratio);\n\n    for (1 .. 30) {\n        my $A     = $ONE;\n        my $log_A = 0;\n\n        my %Q;\n        while ($log_A < $target1) {\n\n            my $p_i = 0;\n            while ($p_i == 0 or exists $Q{$p_i}) {\n                $p_i = $p_min_i + urandomm($p_max_i - $p_min_i + 1);\n            }\n\n            my $fb = $factor_base->[$p_i];\n            $A     *= $fb->{p};\n            $log_A += log($fb->{p});\n            $Q{$p_i} = $fb;\n        }\n\n        my $ratio = exp($log_A - $target0);\n\n        # ratio too small seems to be not good\n        if (   !defined($best_ratio)\n            or ($ratio >= 0.9 and $ratio < $best_ratio)\n            or ($best_ratio < 0.9 and $ratio > $best_ratio)) {\n            $best_q     = \\%Q;\n            $best_a     = $A;\n            $best_ratio = $ratio;\n        }\n    }\n\n    my $A = $best_a;\n    my $B = $ZERO;\n\n    my @arr;\n\n    foreach my $fb (values %$best_q) {\n        my $p = $fb->{p};\n\n        #($A % $p == 0) or die 'error';\n\n        my $r = $A / $p;\n\n        #$fb->{t} // die 'error';\n        #gcd($r, $p) == 1 or die 'error';\n\n        my $gamma = ($fb->{t} * int(invmod($r, $p))) % $p;\n\n        if ($gamma > ($p >> 1)) {\n            $gamma = $p - $gamma;\n        }\n\n        my $t = $r * $gamma;\n\n        $B += $t;\n        push @arr, $t;\n    }\n\n    my ($g, $h) = siqs_create_poly($A, $B, $n, $factor_base, 1);\n\n    return ($g, $h, \\@arr);\n}\n\nsub siqs_find_next_poly ($n, $factor_base, $i, $g, $arr) {\n\n    # Compute the (i+1)-th polynomials for the Self-Initializing\n    # Quadratic Sieve, given that g is the i-th polynomial.\n\n    my $v = valuation($i, 2);\n    my $z = ((($i >> ($v + 1)) & 1) == 0) ? -1 : 1;\n\n    my $A = $g->{a};\n    my $B = ($g->{b} + 2 * $z * $arr->[$v]) % $A;\n\n    return siqs_create_poly($A, $B, $n, $factor_base, 0);\n}\n\nsub siqs_sieve ($factor_base, $m) {\n\n    # Perform the sieving step of the SIQS. Return the sieve array.\n\n    my @sieve_array = (0) x (2 * $m + 1);\n\n    foreach my $fb (@$factor_base) {\n\n        $fb->{p} > 100 or next;\n        $fb->{soln1} // next;\n\n        my $p   = $fb->{p};\n        my $lp  = $fb->{lp};\n        my $end = 2 * $m;\n\n        my $i_start_1 = -int(($m + $fb->{soln1}) / $p);\n        my $a_start_1 = int($fb->{soln1} + $i_start_1 * $p);\n\n        for (my $i = $a_start_1 + $m ; $i <= $end ; $i += $p) {\n            $sieve_array[$i] += $lp;\n        }\n\n        my $i_start_2 = -int(($m + $fb->{soln2}) / $p);\n        my $a_start_2 = int($fb->{soln2} + $i_start_2 * $p);\n\n        for (my $i = $a_start_2 + $m ; $i <= $end ; $i += $p) {\n            $sieve_array[$i] += $lp;\n        }\n    }\n\n    return \\@sieve_array;\n}\n\nsub siqs_trial_divide ($n, $factor_base_info) {\n\n    # Determine whether the given number can be fully factorized into\n    # primes from the factors base. If so, return the indices of the\n    # factors from the factor base. If not, return undef.\n\n    my $factor_prod = $factor_base_info->{prod};\n\n    state $g = Math::GMPz::Rmpz_init_nobless();\n    state $t = Math::GMPz::Rmpz_init_nobless();\n\n    Math::GMPz::Rmpz_set($t, $n);\n    Math::GMPz::Rmpz_gcd($g, $t, $factor_prod);\n\n    while (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {\n\n        Math::GMPz::Rmpz_remove($t, $t, $g);\n\n        if (Math::GMPz::Rmpz_cmp_ui($t, 1) == 0) {\n\n            my $factor_index = $factor_base_info->{index};\n\n            return [map { [$factor_index->{$_->[0]}, $_->[1]] } factor_exp($n)];\n        }\n\n        Math::GMPz::Rmpz_gcd($g, $t, $g);\n    }\n\n    return undef;\n}\n\nsub siqs_trial_division ($n, $sieve_array, $factor_base_info, $smooth_relations, $g, $h, $m, $req_relations) {\n\n    # Perform the trial division step of the Self-Initializing Quadratic Sieve.\n\n    my $limit = (log(\"$m\") + log(\"$n\") / 2) / log(2) - SIQS_TRIAL_DIVISION_EPS;\n\n    foreach my $i (0 .. $#{$sieve_array}) {\n\n        next if ((my $sa = $sieve_array->[$i]) < $limit);\n\n        my $x  = $i - $m;\n        my $gx = abs($g->eval($x));\n\n        my $divisors_idx = siqs_trial_divide($gx, $factor_base_info) // next;\n\n        my $u = $h->eval($x);\n        my $v = $gx;\n\n        #(($u * $u) % $n == ($v % $n)) or die 'error';\n\n        push @$smooth_relations, [$u, $v, $divisors_idx];\n\n        if (scalar(@$smooth_relations) >= $req_relations) {\n            return 1;\n        }\n    }\n\n    return 0;\n}\n\nsub siqs_build_matrix ($factor_base, $smooth_relations) {\n\n    # Build the matrix for the linear algebra step of the Quadratic Sieve.\n    my $fb = scalar(@$factor_base);\n    my @matrix;\n\n    foreach my $sr (@$smooth_relations) {\n        my @row = (0) x $fb;\n        foreach my $pair (@{$sr->[2]}) {\n            $row[$pair->[0]] = $pair->[1] % 2;\n        }\n        push @matrix, \\@row;\n    }\n\n    return \\@matrix;\n}\n\nsub siqs_build_matrix_opt ($M) {\n\n    # Convert the given matrix M of 0s and 1s into a list of numbers m\n    # that correspond to the columns of the matrix.\n    # The j-th number encodes the j-th column of matrix M in binary:\n    # The i-th bit of m[i] is equal to M[i][j].\n\n    my $m           = scalar(@{$M->[0]});\n    my @cols_binary = (\"\") x $m;\n\n    foreach my $mi (@$M) {\n        foreach my $j (0 .. $#{$mi}) {\n            $cols_binary[$j] .= $mi->[$j];\n        }\n    }\n\n#<<<\n    return ([map {\n        Math::GMPz::Rmpz_init_set_str(scalar reverse($_), 2)\n    } @cols_binary], scalar(@$M), $m);\n#>>>\n}\n\nsub find_pivot_column_opt ($M, $j) {\n\n    # For a matrix produced by siqs_build_matrix_opt, return the row of\n    # the first non-zero entry in column j, or None if no such row exists.\n\n    my $v = $M->[$j];\n\n    if ($v == 0) {\n        return undef;\n    }\n\n    return valuation($v, 2);\n}\n\nsub siqs_solve_matrix_opt ($M, $n, $m) {\n\n    # Perform the linear algebra step of the SIQS. Perform fast\n    # Gaussian elimination to determine pairs of perfect squares mod n.\n    # Use the optimizations described in [1].\n\n    # [1] Koç, Çetin K., and Sarath N. Arachchige. 'A Fast Algorithm for\n    #    Gaussian Elimination over GF (2) and its Implementation on the\n    #    GAPP.' Journal of Parallel and Distributed Computing 13.1\n    #    (1991): 118-122.\n\n    my @row_is_marked = (0) x $n;\n    my @pivots        = (-1) x $m;\n\n    foreach my $j (0 .. $m - 1) {\n\n        my $i = find_pivot_column_opt($M, $j) // next;\n\n        $pivots[$j]        = $i;\n        $row_is_marked[$i] = 1;\n\n        foreach my $k (0 .. $m - 1) {\n            if ($k != $j and Math::GMPz::Rmpz_tstbit($M->[$k], $i)) {\n                Math::GMPz::Rmpz_xor($M->[$k], $M->[$k], $M->[$j]);\n            }\n        }\n    }\n\n    my @perf_squares;\n    foreach my $i (0 .. $n - 1) {\n        if (not $row_is_marked[$i]) {\n            my @perfect_sq_indices = ($i);\n            foreach my $j (0 .. $m - 1) {\n                if (Math::GMPz::Rmpz_tstbit($M->[$j], $i)) {\n                    push @perfect_sq_indices, $pivots[$j];\n                }\n            }\n            push @perf_squares, \\@perfect_sq_indices;\n        }\n    }\n\n    return \\@perf_squares;\n}\n\nsub siqs_calc_sqrts ($n, $square_indices, $smooth_relations) {\n\n    # Given on of the solutions returned by siqs_solve_matrix_opt and\n    # the corresponding smooth relations, calculate the pair [a, b], such\n    # that a^2 = b^2 (mod n).\n\n    my $r1 = $ONE;\n    my $r2 = $ONE;\n\n    foreach my $i (@$square_indices) {\n        ($r1 *= $smooth_relations->[$i][0]) %= $n;\n        ($r2 *= $smooth_relations->[$i][1]);\n    }\n\n    $r2 = Math::GMPz->new(sqrtint($r2));\n\n    return ($r1, $r2);\n}\n\nsub siqs_factor_from_square ($n, $square_indices, $smooth_relations) {\n\n    # Given one of the solutions returned by siqs_solve_matrix_opt,\n    # return the factor f determined by f = gcd(a - b, n), where\n    # a, b are calculated from the solution such that a*a = b*b (mod n).\n    # Return f, a factor of n (possibly a trivial one).\n\n    my ($sqrt1, $sqrt2) = siqs_calc_sqrts($n, $square_indices, $smooth_relations);\n\n    #(($sqrt1 * $sqrt1) % $n == ($sqrt2 * $sqrt2) % $n) or die 'error';\n\n    return Math::GMPz->new(gcd($sqrt1 - $sqrt2, $n));\n}\n\nsub siqs_find_more_factors_gcd (@numbers) {\n    my %res;\n\n    foreach my $i (0 .. $#numbers) {\n        my $n = $numbers[$i];\n        $res{$n} = $n;\n        foreach my $k ($i + 1 .. $#numbers) {\n            my $m = $numbers[$k];\n\n            my $fact = Math::GMPz->new(gcd($n, $m));\n            if ($fact != 1 and $fact != $n and $fact != $m) {\n\n                if (not exists($res{$fact})) {\n                    say \"SIQS: GCD found non-trivial factor: $fact\";\n                    $res{$fact} = $fact;\n                }\n\n                my $t1 = $n / $fact;\n                my $t2 = $m / $fact;\n\n                $res{$t1} = $t1;\n                $res{$t2} = $t2;\n            }\n        }\n    }\n\n    return (values %res);\n}\n\nsub siqs_find_factors ($n, $perfect_squares, $smooth_relations) {\n\n    # Perform the last step of the Self-Initializing Quadratic Field.\n    # Given the solutions returned by siqs_solve_matrix_opt, attempt to\n    # identify a number of (not necessarily prime) factors of n, and\n    # return them.\n\n    my @factors;\n    my $rem = $n;\n\n    my %non_prime_factors;\n    my %prime_factors;\n\n    foreach my $square_indices (@$perfect_squares) {\n        my $fact = siqs_factor_from_square($n, $square_indices, $smooth_relations);\n\n        if ($fact > 1 and $fact < $rem) {\n            if (is_prime($fact)) {\n\n                if (not exists $prime_factors{$fact}) {\n                    say \"SIQS: Prime factor found: $fact\";\n                    $prime_factors{$fact} = $fact;\n                }\n\n                $rem = check_factor($rem, $fact, \\@factors);\n\n                if ($rem == 1) {\n                    last;\n                }\n\n                if (is_prime($rem)) {\n                    push @factors, $rem;\n                    $rem = 1;\n                    last;\n                }\n\n                if (defined(my $root = check_perfect_power($rem))) {\n                    say \"SIQS: Perfect power detected with root: $root\";\n                    push @factors, $root;\n                    $rem = 1;\n                    last;\n                }\n            }\n            else {\n                if (not exists $non_prime_factors{$fact}) {\n                    say \"SIQS: Composite factor found: $fact\";\n                    $non_prime_factors{$fact} = $fact;\n                }\n            }\n        }\n    }\n\n    if ($rem != 1 and keys(%non_prime_factors)) {\n        $non_prime_factors{$rem} = $rem;\n\n        my @primes;\n        my @composites;\n\n        foreach my $fact (siqs_find_more_factors_gcd(values %non_prime_factors)) {\n            if (is_prime($fact)) {\n                push @primes, $fact;\n            }\n            elsif ($fact > 1) {\n                push @composites, $fact;\n            }\n        }\n\n        foreach my $fact (@primes, @composites) {\n\n            if ($fact != $rem and $rem % $fact == 0) {\n                say \"SIQS: Using non-trivial factor from GCD: $fact\";\n                $rem = check_factor($rem, $fact, \\@factors);\n            }\n\n            if ($rem == 1 or is_prime($rem)) {\n                last;\n            }\n        }\n    }\n\n    if ($rem != 1) {\n        push @factors, $rem;\n    }\n\n    return @factors;\n}\n\nsub siqs_choose_range ($n) {\n\n    # Choose m for sieving in [-m, m].\n\n    $n = \"$n\";\n\n    return sprintf('%.0f', exp(sqrt(log($n) * log(log($n))) / 2));\n}\n\nsub siqs_choose_nf ($n) {\n\n    # Choose parameters nf (sieve of factor base)\n\n    $n = \"$n\";\n\n    return sprintf('%.0f', exp(sqrt(log($n) * log(log($n))))**(sqrt(2) / 4));\n}\n\nsub siqs_choose_nf2 ($n) {\n\n    # Choose parameters nf (sieve of factor base)\n    $n = \"$n\";\n\n    return sprintf('%.0f', exp(sqrt(log($n) * log(log($n))) / 2));\n}\n\nsub siqs_factorize ($n, $nf) {\n\n    # Use the Self-Initializing Quadratic Sieve algorithm to identify\n    # one or more non-trivial factors of the given number n. Return the\n    # factors as a list.\n\n    my $m = siqs_choose_range($n);\n\n    my @factors;\n    my $factor_base = siqs_factor_base_primes($n, $nf);\n    my $factor_prod = Math::GMPz->new(vecprod(map { $_->{p} } @$factor_base));\n\n    my %factor_base_index;\n    @factor_base_index{map { $_->{p} } @{$factor_base}} = 0 .. $#{$factor_base};\n\n    my $factor_base_info = {\n                            base  => $factor_base,\n                            prod  => $factor_prod,\n                            index => \\%factor_base_index,\n                           };\n\n    my $smooth_relations         = [];\n    my $required_relations_ratio = 1;\n\n    my $success  = 0;\n    my $prev_cnt = 0;\n    my $i_poly   = 0;\n\n    my ($g, $h, $arr);\n\n    while (not $success) {\n\n        say \"*** Step 1/2: Finding smooth relations ***\";\n        say \"SIQS sieving range: [-$m, $m]\";\n\n        my $required_relations = sprintf('%.0f', (scalar(@$factor_base) + 1) * $required_relations_ratio);\n        say \"Target: $required_relations relations.\";\n        my $enough_relations = 0;\n\n        while (not $enough_relations) {\n            if ($i_poly == 0) {\n                ($g, $h, $arr) = siqs_find_first_poly($n, $m, $factor_base);\n            }\n            else {\n                ($g, $h) = siqs_find_next_poly($n, $factor_base, $i_poly, $g, $arr);\n            }\n\n            if (++$i_poly >= (1 << $#{$arr})) {\n                $i_poly = 0;\n            }\n\n            my $sieve_array = siqs_sieve($factor_base, $m);\n\n            $enough_relations = siqs_trial_division($n, $sieve_array, $factor_base_info, $smooth_relations, $g, $h, $m, $required_relations);\n\n            if (   scalar(@$smooth_relations) >= $required_relations\n                or scalar(@$smooth_relations) > $prev_cnt) {\n                printf(\"Progress: %d/%d relations.\\r\", scalar(@$smooth_relations), $required_relations);\n                $prev_cnt = scalar(@$smooth_relations);\n            }\n        }\n\n        say \"\\n\\n*** Step 2/2: Linear Algebra ***\";\n        say \"Building matrix for linear algebra step...\";\n\n        my $M = siqs_build_matrix($factor_base, $smooth_relations);\n        my ($M_opt, $M_n, $M_m) = siqs_build_matrix_opt($M);\n\n        say \"Finding perfect squares using Gaussian elimination...\";\n        my $perfect_squares = siqs_solve_matrix_opt($M_opt, $M_n, $M_m);\n\n        say \"Finding factors from congruences of squares...\\n\";\n        @factors = siqs_find_factors($n, $perfect_squares, $smooth_relations);\n\n        if (scalar(@factors) > 1) {\n            $success = 1;\n        }\n        else {\n            say \"Failed to find a solution. Finding more relations...\";\n            $required_relations_ratio += 0.05;\n        }\n    }\n\n    return @factors;\n}\n\nsub check_factor ($n, $i, $factors) {\n\n    while ($n % $i == 0) {\n\n        $n /= $i;\n        push @$factors, $i;\n\n        if (is_prime($n)) {\n            push @$factors, $n;\n            return 1;\n        }\n    }\n\n    return $n;\n}\n\nsub trial_division_small_primes ($n) {\n\n    # Perform trial division on the given number n using all primes up\n    # to upper_bound. Initialize the global variable small_primes with a\n    # list of all primes <= upper_bound. Return (factors, rem), where\n    # factors is the list of identified prime factors of n, and rem is the\n    # remaining factor. If rem = 1, the function terminates early, without\n    # fully initializing small_primes.\n\n    say \"[*] Trial division...\";\n\n    my $factors = [];\n    my $rem     = $n;\n\n    foreach my $p (@small_primes) {\n        if (Math::GMPz::Rmpz_divisible_ui_p($rem, $p)) {\n            $rem = check_factor($rem, $p, $factors);\n            last if ($rem == 1);\n        }\n    }\n\n    return ($factors, $rem);\n}\n\nsub fast_fibonacci_factor ($n, $upto) {\n\n    my $g = Math::GMPz::Rmpz_init();\n\n    my ($P, $Q) = (3, 1);\n\n    my $U0 = Math::GMPz::Rmpz_init_set_ui(0);\n    my $U1 = Math::GMPz::Rmpz_init_set_ui(1);\n\n    my $V0 = Math::GMPz::Rmpz_init_set_ui(2);\n    my $V1 = Math::GMPz::Rmpz_init_set_ui($P);\n\n    foreach my $k (2 .. $upto) {\n\n        # my ($U, $V) = Math::Prime::Util::GMP::lucas_sequence($n, $P, $Q, $k);\n\n        Math::GMPz::Rmpz_set($g, $U1);\n        Math::GMPz::Rmpz_mul_ui($U1, $U1, $P);\n        Math::GMPz::Rmpz_submul_ui($U1, $U0, $Q);\n        Math::GMPz::Rmpz_mod($U1, $U1, $n);\n        Math::GMPz::Rmpz_set($U0, $g);\n\n        Math::GMPz::Rmpz_set($g, $V1);\n        Math::GMPz::Rmpz_mul_ui($V1, $V1, $P);\n        Math::GMPz::Rmpz_submul_ui($V1, $V0, $Q);\n        Math::GMPz::Rmpz_mod($V1, $V1, $n);\n        Math::GMPz::Rmpz_set($V0, $g);\n\n        foreach my $param ([$U1, 0], [$V1, -$P, -2 * $Q, 0]) {\n\n            my ($t, @deltas) = @$param;\n\n            foreach my $delta (@deltas) {\n\n                ($delta >= 0)\n                  ? Math::GMPz::Rmpz_add_ui($g, $t, $delta)\n                  : Math::GMPz::Rmpz_sub_ui($g, $t, -$delta);\n\n                Math::GMPz::Rmpz_gcd($g, $g, $n);\n\n                if (    Math::GMPz::Rmpz_cmp_ui($g, 1) > 0\n                    and Math::GMPz::Rmpz_cmp($g, $n) < 0) {\n                    return $g;\n                }\n            }\n        }\n    }\n\n    return undef;\n}\n\nsub fast_power_check ($n, $upto) {\n\n    state $t = Math::GMPz::Rmpz_init_nobless();\n    state $g = Math::GMPz::Rmpz_init_nobless();\n\n    my $base_limit = vecmin(logint($n, 2), 150);\n\n    foreach my $base (2 .. $base_limit) {\n\n        Math::GMPz::Rmpz_set_ui($t, $base);\n\n        foreach my $exp (2 .. $upto) {\n\n            Math::GMPz::Rmpz_mul_ui($t, $t, $base);\n\n            foreach my $k ($base <= 10 ? (1 .. ($base_limit >> 1)) : 1) {\n                Math::GMPz::Rmpz_mul_ui($g, $t, $k);\n\n                Math::GMPz::Rmpz_sub_ui($g, $g, 1);\n                Math::GMPz::Rmpz_gcd($g, $g, $n);\n\n                if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0 and Math::GMPz::Rmpz_cmp($g, $n) < 0) {\n                    return Math::GMPz::Rmpz_init_set($g);\n                }\n\n                Math::GMPz::Rmpz_mul_ui($g, $t, $k);\n                Math::GMPz::Rmpz_add_ui($g, $g, 1);\n                Math::GMPz::Rmpz_gcd($g, $g, $n);\n\n                if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0 and Math::GMPz::Rmpz_cmp($g, $n) < 0) {\n                    return Math::GMPz::Rmpz_init_set($g);\n                }\n            }\n        }\n    }\n\n    return undef;\n}\n\nsub cyclotomic_polynomial ($n, $x, $m) {\n\n    $x = Math::GMPz::Rmpz_init_set_ui($x) if !ref($x);\n\n    # Generate the squarefree divisors of n, along\n    # with the number of prime factors of each divisor\n    my @sd;\n    foreach my $pe (factor_exp($n)) {\n        my ($p) = @$pe;\n        push @sd, map { [$_->[0] * $p, $_->[1] + 1] } @sd;\n        push @sd, [$p, 1];\n    }\n\n    push @sd, [Math::GMPz::Rmpz_init_set_ui(1), 0];\n\n    my $prod = Math::GMPz::Rmpz_init_set_ui(1);\n\n    foreach my $pair (@sd) {\n        my ($d, $c) = @$pair;\n\n        my $base = Math::GMPz::Rmpz_init();\n        my $exp  = CORE::int($n / $d);\n\n        Math::GMPz::Rmpz_powm_ui($base, $x, $exp, $m);    # x^(n/d) mod m\n        Math::GMPz::Rmpz_sub_ui($base, $base, 1);\n\n        if ($c % 2 == 1) {\n            Math::GMPz::Rmpz_invert($base, $base, $m) || return $base;\n        }\n\n        Math::GMPz::Rmpz_mul($prod, $prod, $base);\n        Math::GMPz::Rmpz_mod($prod, $prod, $m);\n    }\n\n    return $prod;\n}\n\nsub cyclotomic_factorization ($n) {\n\n    my $g          = Math::GMPz::Rmpz_init();\n    my $base_limit = vecmin(1 + logint($n, 2), 1000);\n\n    for (my $base = $base_limit ; $base >= 2 ; $base -= 1) {\n        my $lim = 1 + logint($n, $base);\n\n        foreach my $k (1 .. $lim) {\n            my $c = cyclotomic_polynomial($k, $base, $n);\n            Math::GMPz::Rmpz_gcd($g, $n, $c);\n            if (    Math::GMPz::Rmpz_cmp_ui($g, 1) > 0\n                and Math::GMPz::Rmpz_cmp($g, $n) < 0) {\n                return $g;\n            }\n        }\n    }\n\n    return undef;\n}\n\nsub fast_lucasVmod ($P, $n, $m) {    # assumes Q = 1\n\n    my ($V1, $V2) = (Math::GMPz::Rmpz_init_set_ui(2), Math::GMPz::Rmpz_init_set($P));\n\n    foreach my $bit (todigits($n, 2)) {\n\n        if ($bit) {\n            Math::GMPz::Rmpz_mul($V1, $V1, $V2);\n            Math::GMPz::Rmpz_powm_ui($V2, $V2, 2, $m);\n            Math::GMPz::Rmpz_sub($V1, $V1, $P);\n            Math::GMPz::Rmpz_sub_ui($V2, $V2, 2);\n            Math::GMPz::Rmpz_mod($V1, $V1, $m);\n        }\n        else {\n            Math::GMPz::Rmpz_mul($V2, $V2, $V1);\n            Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $m);\n            Math::GMPz::Rmpz_sub($V2, $V2, $P);\n            Math::GMPz::Rmpz_sub_ui($V1, $V1, 2);\n            Math::GMPz::Rmpz_mod($V2, $V2, $m);\n        }\n    }\n\n    return $V1;\n}\n\nsub chebyshev_factorization ($n, $B, $A = 127) {\n\n    # The Chebyshev factorization method, taking\n    # advantage of the smoothness of p-1 or p+1.\n\n    my $x = Math::GMPz::Rmpz_init_set_ui($A);\n    my $i = Math::GMPz::Rmpz_init_set_ui(2);\n\n    Math::GMPz::Rmpz_invert($i, $i, $n);\n\n    my $chebyshevTmod = sub ($A, $x) {\n        Math::GMPz::Rmpz_mul_2exp($x, $x, 1);\n        Math::GMPz::Rmpz_set($x, fast_lucasVmod($x, $A, $n));\n        Math::GMPz::Rmpz_mul($x, $x, $i);\n        Math::GMPz::Rmpz_mod($x, $x, $n);\n    };\n\n    my $g   = Math::GMPz::Rmpz_init();\n    my $lnB = 2 * log($B);\n    my $s   = sqrtint($B);\n\n    foreach my $p (@{primes(2, $s)}) {\n        for (1 .. int($lnB / log($p))) {\n            $chebyshevTmod->($p, $x);    # T_k(x) (mod n)\n        }\n    }\n\n    my $it = prime_iterator($s + 1);\n    for (my $p = $it->() ; $p <= $B ; $p = $it->()) {\n\n        $chebyshevTmod->($p, $x);    # T_k(x) (mod n)\n\n        Math::GMPz::Rmpz_sub_ui($g, $x, 1);\n        Math::GMPz::Rmpz_gcd($g, $g, $n);\n\n        if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {\n            return undef if (Math::GMPz::Rmpz_cmp($g, $n) == 0);\n            return $g;\n        }\n    }\n\n    return undef;\n}\n\nsub fibonacci_factorization ($n, $bound) {\n\n    # The Fibonacci factorization method, taking\n    # advantage of the smoothness of `p - legendre(p, 5)`.\n\n    my ($P, $Q) = (1, 0);\n\n    for (my $k = 2 ; ; ++$k) {\n        my $D = (-1)**$k * (2 * $k + 1);\n\n        if (Math::GMPz::Rmpz_si_kronecker($D, $n) == -1) {\n            $Q = (1 - $D) / 4;\n            last;\n        }\n    }\n\n    state %cache;\n    my $g = Math::GMPz::Rmpz_init();\n\n    for (; ;) {\n        return undef if $bound <= 1;\n\n        my $d = ($cache{$bound} //= consecutive_integer_lcm($bound));\n        my ($U, $V) = map { Math::GMPz::Rmpz_init_set_str($_, 10) } lucas_sequence($n, $P, $Q, $d);\n\n        foreach my $t ($U, $V - 2, $V, $V + 2) {\n\n            Math::GMPz::Rmpz_gcd($g, $t, $n);\n\n            if (    Math::GMPz::Rmpz_cmp_ui($g, 1) > 0\n                and Math::GMPz::Rmpz_cmp($g, $n) < 0) {\n                return $g;\n            }\n        }\n\n        if ($U == 0) {\n            say \":: p±1 seems to be $bound-smooth...\";\n            $bound >>= 1;\n            next;\n        }\n\n        say \"=> Lucas p±1...\";\n        return lucas_factorization($n, Math::GMPz::Rmpz_init_set_str($d, 10));\n    }\n}\n\nsub lucas_factorization ($n, $d) {\n\n    # The Lucas factorization method, taking\n    # advantage of the smoothness of p-1 or p+1.\n\n    my $Q;\n    for (my $k = 2 ; ; ++$k) {\n        my $D = (-1)**$k * (2 * $k + 1);\n\n        if (Math::GMPz::Rmpz_si_kronecker($D, $n) == -1) {\n            $Q = (1 - $D) / 4;\n            last;\n        }\n    }\n\n    my $s  = Math::GMPz::Rmpz_scan1($d, 0);\n    my $U1 = Math::GMPz::Rmpz_init_set_ui(1);\n\n    my ($V1, $V2) = (Math::GMPz::Rmpz_init_set_ui(2), Math::GMPz::Rmpz_init_set_ui(1));\n    my ($Q1, $Q2) = (Math::GMPz::Rmpz_init_set_ui(1), Math::GMPz::Rmpz_init_set_ui(1));\n\n    foreach my $bit (split(//, substr(Math::GMPz::Rmpz_get_str($d, 2), 0, -$s - 1))) {\n\n        Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);\n        Math::GMPz::Rmpz_mod($Q1, $Q1, $n);\n\n        if ($bit) {\n            Math::GMPz::Rmpz_mul_si($Q2, $Q1, $Q);\n            Math::GMPz::Rmpz_mul($U1, $U1, $V2);\n            Math::GMPz::Rmpz_mul($V1, $V1, $V2);\n\n            Math::GMPz::Rmpz_powm_ui($V2, $V2, 2, $n);\n            Math::GMPz::Rmpz_sub($V1, $V1, $Q1);\n            Math::GMPz::Rmpz_submul_ui($V2, $Q2, 2);\n\n            Math::GMPz::Rmpz_mod($V1, $V1, $n);\n            Math::GMPz::Rmpz_mod($U1, $U1, $n);\n        }\n        else {\n            Math::GMPz::Rmpz_set($Q2, $Q1);\n            Math::GMPz::Rmpz_mul($U1, $U1, $V1);\n            Math::GMPz::Rmpz_mul($V2, $V2, $V1);\n            Math::GMPz::Rmpz_sub($U1, $U1, $Q1);\n\n            Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $n);\n            Math::GMPz::Rmpz_sub($V2, $V2, $Q1);\n            Math::GMPz::Rmpz_submul_ui($V1, $Q2, 2);\n\n            Math::GMPz::Rmpz_mod($V2, $V2, $n);\n            Math::GMPz::Rmpz_mod($U1, $U1, $n);\n        }\n    }\n\n    Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);\n    Math::GMPz::Rmpz_mul_si($Q2, $Q1, $Q);\n    Math::GMPz::Rmpz_mul($U1, $U1, $V1);\n    Math::GMPz::Rmpz_mul($V1, $V1, $V2);\n    Math::GMPz::Rmpz_sub($U1, $U1, $Q1);\n    Math::GMPz::Rmpz_sub($V1, $V1, $Q1);\n    Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);\n\n    my $t = Math::GMPz::Rmpz_init();\n\n    Math::GMPz::Rmpz_gcd($t, $U1, $n);\n\n    if (    Math::GMPz::Rmpz_cmp_ui($t, 1) > 0\n        and Math::GMPz::Rmpz_cmp($t, $n) < 0) {\n        return $t;\n    }\n\n    Math::GMPz::Rmpz_gcd($t, $V1, $n);\n\n    if (    Math::GMPz::Rmpz_cmp_ui($t, 1) > 0\n        and Math::GMPz::Rmpz_cmp($t, $n) < 0) {\n        return $t;\n    }\n\n    for (1 .. $s) {\n\n        Math::GMPz::Rmpz_mul($U1, $U1, $V1);\n        Math::GMPz::Rmpz_mod($U1, $U1, $n);\n        Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $n);\n        Math::GMPz::Rmpz_submul_ui($V1, $Q1, 2);\n        Math::GMPz::Rmpz_powm_ui($Q1, $Q1, 2, $n);\n\n        Math::GMPz::Rmpz_gcd($t, $U1, $n);\n\n        if (    Math::GMPz::Rmpz_cmp_ui($t, 1) > 0\n            and Math::GMPz::Rmpz_cmp($t, $n) < 0) {\n            return $t;\n        }\n\n        Math::GMPz::Rmpz_gcd($t, $V1, $n);\n\n        if (    Math::GMPz::Rmpz_cmp_ui($t, 1) > 0\n            and Math::GMPz::Rmpz_cmp($t, $n) < 0) {\n            return $t;\n        }\n    }\n\n    return undef;\n}\n\nsub pollard_pm1_lcm_find_factor ($n, $bound) {\n\n    # Pollard p-1 method (LCM).\n\n    my $g = Math::GMPz::Rmpz_init();\n    my $t = Math::GMPz::Rmpz_init_set_ui(random_prime(1e6));\n\n    foreach my $p (sieve_primes(2, $bound)) {\n\n        Math::GMPz::Rmpz_powm_ui($t, $t, $p**int(log(ULONG_MAX >> 32) / log($p)), $n);\n        Math::GMPz::Rmpz_sub_ui($g, $t, 1);\n        Math::GMPz::Rmpz_gcd($g, $g, $n);\n\n        if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {\n            return undef if ($g == $n);\n            return $g;\n        }\n    }\n\n    return undef;\n}\n\nsub pollard_pm1_factorial_find_factor ($n, $bound2) {\n\n    # Pollard p-1 method (factorial).\n\n    my $bound1 = 1e5;\n\n    state %cache;\n\n    my $g = Math::GMPz::Rmpz_init();\n    my $t = Math::GMPz::Rmpz_init_set_ui(random_prime(1e6));\n\n    if (exists $cache{$n}) {\n        $t      = $cache{$n}{value};\n        $bound1 = $cache{$n}{bound};\n    }\n    else {\n        foreach my $k (2 .. $bound1) {\n\n            Math::GMPz::Rmpz_powm_ui($t, $t, $k, $n);\n            Math::GMPz::Rmpz_sub_ui($g, $t, 1);\n            Math::GMPz::Rmpz_gcd($g, $g, $n);\n\n            if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {\n                return undef if ($g == $n);\n                return $g;\n            }\n        }\n    }\n\n    while ($bound1 >= $bound2) {\n        $bound2 *= 2;\n    }\n\n    foreach my $p (sieve_primes($bound1, $bound2)) {\n\n        Math::GMPz::Rmpz_powm_ui($t, $t, $p, $n);\n        Math::GMPz::Rmpz_sub_ui($g, $t, 1);\n        Math::GMPz::Rmpz_gcd($g, $g, $n);\n\n        if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {\n            return undef if ($g == $n);\n            return $g;\n        }\n    }\n\n    $cache{$n}{value} = $t;\n    $cache{$n}{bound} = $bound2 + 1;\n\n    return undef;\n}\n\nsub pollard_rho_find_factor ($n, $max_iter) {\n\n    # Pollard rho method, using the polynomial:\n    #   f(x) = x^2 - 1, with x_0 = 1+floor(log_2(n)).\n\n    state %cache;\n\n    my $u = logint($n, 2) + 1;\n    my $x = Math::GMPz::Rmpz_init_set_ui($u);\n    my $y = Math::GMPz::Rmpz_init_set_ui($u * $u - 1);\n\n    if (exists $cache{$n}) {\n        $x = $cache{$n}{x};\n        $y = $cache{$n}{y};\n    }\n\n    my $g = Math::GMPz::Rmpz_init();\n\n    for (1 .. $max_iter) {\n\n        # f(x) = x^2 - 1\n        Math::GMPz::Rmpz_powm_ui($x, $x, 2, $n);\n        Math::GMPz::Rmpz_sub_ui($x, $x, 1);\n\n        # f(f(x)) = (x^2 - 1)^2 - 1 = (x^2 - 2) * x^2\n        Math::GMPz::Rmpz_powm_ui($g, $y, 2, $n);\n        Math::GMPz::Rmpz_sub_ui($y, $g, 2);\n        Math::GMPz::Rmpz_mul($y, $y, $g);\n\n        Math::GMPz::Rmpz_sub($g, $x, $y);\n        Math::GMPz::Rmpz_gcd($g, $g, $n);\n\n        if (Math::GMPz::Rmpz_cmp_ui($g, 1) != 0) {\n            return undef if ($g == $n);\n            return $g;\n        }\n    }\n\n    $cache{$n}{x} = $x;\n    $cache{$n}{y} = $y;\n\n    return undef;\n}\n\nsub pollard_pm1_ntheory_factor ($n, $max_iter) {\n    my ($p, $q) = Math::Prime::Util::GMP::pminus1_factor($n, $max_iter);\n    return $p if defined($q);\n    return pollard_pm1_factorial_find_factor($n, $max_iter);\n}\n\nsub williams_pp1_ntheory_factor ($n, $max_iter) {\n    my ($p, $q) = Math::Prime::Util::GMP::pplus1_factor($n, $max_iter);\n    return $p if defined($q);\n    return undef;\n}\n\nsub pollard_rho_ntheory_factor ($n, $max_iter) {\n    my ($p, $q) =\n        (rand(1) < 0.5)\n      ? (Math::Prime::Util::GMP::prho_factor($n, $max_iter))\n      : (Math::Prime::Util::GMP::pbrent_factor($n, $max_iter));\n    return $p if defined($q);\n    return pollard_rho_find_factor($n, $max_iter >> 1);\n}\n\nsub pollard_rho_sqrt_find_factor ($n, $max_iter) {\n\n    # Pollard rho method, using the polynomial:\n    #   f(x) = x^2 + c\n    #\n    # where\n    #   c = floor(sqrt(n)) - (floor(sqrt(n))^2 - n)\n    #   c = n + s - s^2, with s = floor(sqrt(n))\n    #\n    # and\n    #   x_0 = 3^2 + c\n\n    my $s = Math::GMPz->new(sqrtint($n));\n    my $c = $n + $s - $s * $s;\n\n    my $a0 = 3;\n    my $a1 = ($a0 * $a0 + $c);\n    my $a2 = ($a1 * $a1 + $c);\n\n    my $g = Math::GMPz::Rmpz_init();\n\n    for (1 .. $max_iter) {\n\n        Math::GMPz::Rmpz_sub($g, $a2, $a1);\n        Math::GMPz::Rmpz_gcd($g, $g, $n);\n\n        if (Math::GMPz::Rmpz_cmp_ui($g, 1) != 0) {\n            return undef if ($g == $n);\n            return $g;\n        }\n\n        Math::GMPz::Rmpz_powm_ui($a1, $a1, 2, $n);\n        Math::GMPz::Rmpz_add($a1, $a1, $c);\n\n        Math::GMPz::Rmpz_powm_ui($a2, $a2, 2, $n);\n        Math::GMPz::Rmpz_add($a2, $a2, $c);\n\n        Math::GMPz::Rmpz_powm_ui($a2, $a2, 2, $n);\n        Math::GMPz::Rmpz_add($a2, $a2, $c);\n    }\n\n    return undef;\n}\n\nsub pollard_rho_exp_find_factor ($n, $max_iter) {\n\n    my $B = logint($n, 5)**2;\n\n    if ($B > 50_000) {\n        $B = 50_000;\n    }\n\n    my $e = Math::GMPz::Rmpz_init_set_str(consecutive_integer_lcm($B), 10);\n    my $c = 2 * $e - 1;\n\n    my $x = Math::GMPz::Rmpz_init_set_ui(1);\n    my $y = Math::GMPz::Rmpz_init();\n    my $g = Math::GMPz::Rmpz_init();\n\n    Math::GMPz::Rmpz_powm($x, $x, $e, $n);\n    Math::GMPz::Rmpz_add($x, $x, $c);\n    Math::GMPz::Rmpz_mod($x, $x, $n);\n\n    Math::GMPz::Rmpz_powm($y, $x, $e, $n);\n    Math::GMPz::Rmpz_add($y, $y, $c);\n    Math::GMPz::Rmpz_mod($y, $y, $n);\n\n    for (1 .. $max_iter) {\n\n        Math::GMPz::Rmpz_powm($x, $x, $e, $n);\n        Math::GMPz::Rmpz_add($x, $x, $c);\n        Math::GMPz::Rmpz_mod($x, $x, $n);\n\n        Math::GMPz::Rmpz_powm($y, $y, $e, $n);\n        Math::GMPz::Rmpz_add($y, $y, $c);\n        Math::GMPz::Rmpz_mod($y, $y, $n);\n\n        Math::GMPz::Rmpz_powm($y, $y, $e, $n);\n        Math::GMPz::Rmpz_add($y, $y, $c);\n        Math::GMPz::Rmpz_mod($y, $y, $n);\n\n        Math::GMPz::Rmpz_sub($g, $x, $y);\n        Math::GMPz::Rmpz_gcd($g, $g, $n);\n\n        if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {\n            return undef if (Math::GMPz::Rmpz_cmp($g, $n) == 0);\n            return $g;\n        }\n    }\n\n    return undef;\n}\n\nsub phi_finder_factor ($n, $max_iter) {\n\n    # Phi-finder algorithm for semiprimes, due to Kyle Kloster (2010)\n\n    my $E  = $n - 2 * Math::GMPz->new(sqrtint($n)) + 1;\n    my $E0 = Math::GMPz->new(powmod(2, -$E, $n));\n\n    my $L = logint($n, 2);\n    my $i = 0;\n\n    # Repeat until E0 is a power of 2\n    while (Math::GMPz::Rmpz_popcount($E0) != 1) {\n        Math::GMPz::Rmpz_mul_2exp($E0, $E0, $L);\n        Math::GMPz::Rmpz_mod($E0, $E0, $n);\n        return undef if (++$i > $max_iter);\n    }\n\n    my $t = 0;\n\n    foreach my $k (0 .. $L) {\n        if (Math::GMPz->new(powmod(2, $k, $n)) == $E0) {\n            $t = $k;\n            last;\n        }\n    }\n\n    my $phi = abs($i * $L - $E - $t);\n\n    my $q = ($n - $phi + 1);\n    my $p = ($q + Math::GMPz->new(sqrtint(abs($q * $q - 4 * $n)))) >> 1;\n\n    (($n % $p) == 0) ? $p : undef;\n}\n\nsub FLT_find_factor ($n, $base = 2, $reps = 1e4) {\n\n    # Find a prime factor of n if all the prime factors of n are close to each other.\n    # Inpsired by Fermat's little theorem.\n\n    state $z = Math::GMPz::Rmpz_init_nobless();\n    state $t = Math::GMPz::Rmpz_init_nobless();\n\n    my $g = Math::GMPz::Rmpz_init();\n\n    Math::GMPz::Rmpz_set_ui($t, $base);\n    Math::GMPz::Rmpz_set_ui($z, $base);\n\n    Math::GMPz::Rmpz_powm($z, $z, $n, $n);\n\n    # Cannot factor Fermat pseudoprimes\n    if (Math::GMPz::Rmpz_cmp_ui($z, $base) == 0) {\n        return undef;\n    }\n\n    my $multiplier = $base * $base;\n\n    for (my $k = 1 ; $k <= $reps ; $k += 1) {\n\n        Math::GMPz::Rmpz_mul_ui($t, $t, $multiplier);\n        Math::GMPz::Rmpz_mod($t, $t, $n) if ($k % 10 == 0);\n        Math::GMPz::Rmpz_sub($g, $z, $t);\n        Math::GMPz::Rmpz_gcd($g, $g, $n);\n\n        if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {\n            return undef if (Math::GMPz::Rmpz_cmp($g, $n) == 0);\n            return $g;\n        }\n    }\n\n    return undef;\n}\n\nsub sophie_germain_factor ($n) {\n\n    # A simple factorization method, based on Sophie Germain's identity:\n    #   x^4 + 4y^4 = (x^2 + 2xy + 2y^2) * (x^2 - 2xy + 2y^2)\n\n    # This method is also effective for numbers of the form: n^4 + 4^(2k+1).\n\n    state $w = Math::GMPz::Rmpz_init_nobless();\n    state $z = Math::GMPz::Rmpz_init_nobless();\n\n    my $sophie_germain_decomposition = sub ($n) {\n\n        state $t = Math::GMPz::Rmpz_init();\n        state $u = Math::GMPz::Rmpz_init();\n\n        Math::GMPz::Rmpz_root($t, $n, 4);\n        Math::GMPz::Rmpz_pow_ui($w, $t, 4);\n        Math::GMPz::Rmpz_sub($u, $n, $w);\n        Math::GMPz::Rmpz_div_2exp($u, $u, 2);\n\n        if (Math::GMPz::Rmpz_root($u, $u, 4)) {\n\n            # n = t^4 + 4*u^4\n            Math::GMPz::Rmpz_pow_ui($z, $u, 4);\n            Math::GMPz::Rmpz_mul_2exp($z, $z, 2);\n            Math::GMPz::Rmpz_add($w, $w, $z);\n\n            if (Math::GMPz::Rmpz_cmp($w, $n) == 0) {\n                say \"[*] Sophie Germain form detected: $t^4 + 4*$u^4\";\n                return ($t, $u);\n            }\n        }\n\n        Math::GMPz::Rmpz_mul_2exp($t, $n, 2);\n        Math::GMPz::Rmpz_root($t, $t, 4);\n        Math::GMPz::Rmpz_div_2exp($t, $t, 1);\n        Math::GMPz::Rmpz_pow_ui($z, $t, 4);\n        Math::GMPz::Rmpz_mul_2exp($z, $z, 2);\n        Math::GMPz::Rmpz_sub($u, $n, $z);\n\n        if (Math::GMPz::Rmpz_root($u, $u, 4)) {\n\n            # n = u^4 + 4*t^4\n            Math::GMPz::Rmpz_pow_ui($w, $u, 4);\n            Math::GMPz::Rmpz_add($w, $w, $z);\n\n            if (Math::GMPz::Rmpz_cmp($w, $n) == 0) {\n                say \"[*] Sophie Germain form detected: $u^4 + 4*$t^4\";\n                return ($u, $t);\n            }\n        }\n\n        return;\n    };\n\n    my ($x, $y) = $sophie_germain_decomposition->($n);\n\n    if (!defined($x) or !defined($y)) {\n        return undef;\n    }\n\n    my $p = Math::GMPz::Rmpz_init();\n\n    Math::GMPz::Rmpz_mul($w, $x, $y);\n    Math::GMPz::Rmpz_mul_2exp($w, $w, 1);\n    Math::GMPz::Rmpz_mul($z, $x, $x);\n    Math::GMPz::Rmpz_sub($p, $z, $w);\n    Math::GMPz::Rmpz_mul($w, $y, $y);\n    Math::GMPz::Rmpz_mul_2exp($w, $w, 1);\n    Math::GMPz::Rmpz_add($p, $p, $w);\n\n    return $p;\n}\n\n{\n    state $state = Math::GMPz::zgmp_randinit_mt_nobless();\n    Math::GMPz::zgmp_randseed_ui($state, scalar srand());\n\n    sub MBE_find_factor ($n, $max_k = 1000) {\n\n        my $t = Math::GMPz::Rmpz_init();\n        my $g = Math::GMPz::Rmpz_init();\n\n        my $a = Math::GMPz::Rmpz_init();\n        my $b = Math::GMPz::Rmpz_init();\n        my $c = Math::GMPz::Rmpz_init();\n\n        foreach my $k (1 .. $max_k) {\n\n            # Deterministic version\n            # Math::GMPz::Rmpz_div_ui($t, $n, $k+1);\n\n            # Randomized version\n            Math::GMPz::Rmpz_urandomm($t, $state, $n, 1);\n\n            Math::GMPz::Rmpz_set($a, $t);\n            Math::GMPz::Rmpz_set($b, $t);\n            Math::GMPz::Rmpz_set_ui($c, 1);\n\n            foreach my $i (0 .. Math::GMPz::Rmpz_sizeinbase($b, 2) - 1) {\n\n                if (Math::GMPz::Rmpz_tstbit($b, $i)) {\n\n                    Math::GMPz::Rmpz_powm($c, $a, $c, $n);\n                    Math::GMPz::Rmpz_sub_ui($g, $c, 1);\n                    Math::GMPz::Rmpz_gcd($g, $g, $n);\n\n                    if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0 and Math::GMPz::Rmpz_cmp($g, $n) < 0) {\n                        return $g;\n                    }\n                }\n\n                Math::GMPz::Rmpz_powm($a, $a, $a, $n);\n            }\n        }\n\n        return undef;\n    }\n}\n\nsub fermat_find_factor ($n, $max_iter) {\n\n    # Fermat's factorization method, trying to represent `n` as a difference of two squares:\n    #   n = a^2 - b^2, where n = (a-b) * (a+b).\n\n    my $p = Math::GMPz::Rmpz_init();    # p = floor(sqrt(n))\n    my $q = Math::GMPz::Rmpz_init();    # q = p^2 - n\n\n    Math::GMPz::Rmpz_sqrtrem($p, $q, $n);\n    Math::GMPz::Rmpz_neg($q, $q);\n\n    for (my $j = 1 ; $j <= $max_iter ; ++$j) {\n\n        Math::GMPz::Rmpz_addmul_ui($q, $p, 2);\n\n        Math::GMPz::Rmpz_add_ui($q, $q, 1);\n        Math::GMPz::Rmpz_add_ui($p, $p, 1);\n\n        if (Math::GMPz::Rmpz_perfect_square_p($q)) {\n            Math::GMPz::Rmpz_sqrt($q, $q);\n\n            my $r = Math::GMPz::Rmpz_init();\n            Math::GMPz::Rmpz_sub($r, $p, $q);\n\n            return $r;\n        }\n    }\n\n    return undef;\n}\n\nsub holf_ntheory_find_factor ($n, $max_iter) {\n    my ($p, $q) = Math::Prime::Util::GMP::holf_factor($n, $max_iter);\n    return $p if defined($q);\n    return undef;\n}\n\nsub holf_find_factor ($n, $max_iter) {\n\n    # Hart’s One-Line Factoring Algorithm\n\n    my $m = Math::GMPz::Rmpz_init();\n    my $s = Math::GMPz::Rmpz_init();\n\n    foreach my $i (1 .. $max_iter) {\n\n        Math::GMPz::Rmpz_mul_ui($s, $n, 4 * $i);\n        Math::GMPz::Rmpz_sqrt($s, $s);\n        Math::GMPz::Rmpz_add_ui($s, $s, 1);\n\n        Math::GMPz::Rmpz_mul($m, $s, $s);\n        Math::GMPz::Rmpz_mod($m, $m, $n);\n\n        if (Math::GMPz::Rmpz_perfect_square_p($m)) {\n\n            Math::GMPz::Rmpz_sqrt($m, $m);\n            Math::GMPz::Rmpz_sub($m, $s, $m);\n            Math::GMPz::Rmpz_gcd($m, $m, $n);\n\n            if (    Math::GMPz::Rmpz_cmp_ui($m, 1) > 0\n                and Math::GMPz::Rmpz_cmp($m, $n) < 0) {\n                return $m;\n            }\n        }\n    }\n\n    return undef;\n}\n\nsub ecm_find_factor ($n, $B1, $ncurves) {\n    my ($p, $q) = Math::Prime::Util::GMP::ecm_factor($n, $B1, $ncurves);\n    return $p if defined($q);\n    return undef;\n}\n\nsub miller_rabin_factor ($n, $tries) {\n\n    # Miller-Rabin factorization method.\n    # https://en.wikipedia.org/wiki/Miller%E2%80%93Rabin_primality_test\n\n    my $D = $n - 1;\n    my $s = Math::GMPz::Rmpz_scan1($D, 0);\n    my $r = $s - 1;\n    my $d = $D >> $s;\n\n    if ($s > 20 and $tries > 10) {\n        $tries = 1 + int(2 * (100 / $s));\n    }\n\n    my $x = Math::GMPz::Rmpz_init();\n    my $g = Math::GMPz::Rmpz_init();\n\n    for (1 .. $tries) {\n\n        my $p = random_prime(1e7);\n        Math::GMPz::Rmpz_powm($x, Math::GMPz::Rmpz_init_set_ui($p), $d, $n);\n\n        foreach my $k (0 .. $r) {\n\n            last if (Math::GMPz::Rmpz_cmp_ui($x, 1) == 0);\n            last if (Math::GMPz::Rmpz_cmp($x, $D) == 0);\n\n            foreach my $i (1, -1) {\n                Math::GMPz::Rmpz_gcd($g, $x + $i, $n);\n                if (    Math::GMPz::Rmpz_cmp_ui($g, 1) > 0\n                    and Math::GMPz::Rmpz_cmp($g, $n) < 0) {\n                    return $g;\n                }\n            }\n\n            Math::GMPz::Rmpz_powm_ui($x, $x, 2, $n);\n        }\n    }\n\n    return undef;\n}\n\nsub lucas_miller_factor ($n, $j, $tries) {\n\n    # Lucas-Miller factorization method.\n\n    my $D = $n + $j;\n    my $s = Math::GMPz::Rmpz_scan1($D, 0);\n    my $r = $s;\n    my $d = $D >> $s;\n\n    $d = Math::GMPz::Rmpz_get_str($d, 10);\n\n    if ($s > 10 and $tries > 5) {\n        $tries //= 1 + int(100 / $s);\n    }\n\n    my $g = Math::GMPz::Rmpz_init();\n\n    foreach my $i (1 .. $tries) {\n\n        my $P = 1 + int(rand(1e6));\n        my $Q = 1 + int(rand(1e6));\n\n        $Q *= -1 if (rand(1) < 0.5);\n\n        next if is_square($P * $P - 4 * $Q);\n\n        my ($U1, $V1, $Q1) =\n          map { Math::GMPz::Rmpz_init_set_str($_, 10) } lucas_sequence($n, $P, $Q, $d);\n\n        foreach my $k (1 .. $r) {\n\n            foreach my $t ($U1, $V1, $P) {\n                if (ref($t)) {\n                    Math::GMPz::Rmpz_gcd($g, $t, $n);\n                }\n                else {\n                    Math::GMPz::Rmpz_sub_ui($g, $V1, $t);\n                    Math::GMPz::Rmpz_gcd($g, $g, $n);\n                }\n                if (    Math::GMPz::Rmpz_cmp_ui($g, 1) > 0\n                    and Math::GMPz::Rmpz_cmp($g, $n) < 0) {\n                    return $g;\n                }\n            }\n\n            Math::GMPz::Rmpz_mul($U1, $U1, $V1);\n            Math::GMPz::Rmpz_mod($U1, $U1, $n);\n            Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $n);\n            Math::GMPz::Rmpz_submul_ui($V1, $Q1, 2);\n            Math::GMPz::Rmpz_powm_ui($Q1, $Q1, 2, $n);\n        }\n    }\n\n    return undef;\n}\n\nsub pell_find_factor ($n, $max_iter) {\n\n    # Simple version of the continued-fraction factorization method.\n    # Efficient for numbers that have factors relatively close to sqrt(n)\n\n    my $x = Math::GMPz::Rmpz_init();\n    my $y = Math::GMPz::Rmpz_init();\n    my $z = Math::GMPz::Rmpz_init_set_ui(1);\n\n    my $t = Math::GMPz::Rmpz_init();\n    my $w = Math::GMPz::Rmpz_init();\n    my $r = Math::GMPz::Rmpz_init();\n\n    Math::GMPz::Rmpz_sqrt($x, $n);\n    Math::GMPz::Rmpz_set($y, $x);\n\n    Math::GMPz::Rmpz_add($w, $x, $x);\n    Math::GMPz::Rmpz_set($r, $w);\n\n    my $f2 = Math::GMPz::Rmpz_init_set($x);\n    my $f1 = Math::GMPz::Rmpz_init_set_ui(1);\n\n    foreach my $k (1 .. $max_iter) {\n\n        # y = r*z - y\n        Math::GMPz::Rmpz_mul($t, $r, $z);\n        Math::GMPz::Rmpz_sub($y, $t, $y);\n\n        # z = (n - y*y) / z\n        Math::GMPz::Rmpz_mul($t, $y, $y);\n        Math::GMPz::Rmpz_sub($t, $n, $t);\n        Math::GMPz::Rmpz_divexact($z, $t, $z);\n\n        # r = (x + y) / z\n        Math::GMPz::Rmpz_add($t, $x, $y);\n\n        # Floor division: floor((x+y)/z)\n        # Math::GMPz::Rmpz_div($r, $t, $z);\n\n        # Round (x+y)/z to nearest integer\n        Math::GMPz::Rmpz_set($r, $z);\n        Math::GMPz::Rmpz_addmul_ui($r, $t, 2);\n        Math::GMPz::Rmpz_div($r, $r, $z);\n        Math::GMPz::Rmpz_div_2exp($r, $r, 1);\n\n        # f1 = (f1 + r*f2) % n\n        Math::GMPz::Rmpz_addmul($f1, $f2, $r);\n        Math::GMPz::Rmpz_mod($f1, $f1, $n);\n\n        # swap f1 with f2\n        ($f1, $f2) = ($f2, $f1);\n\n        if (Math::GMPz::Rmpz_perfect_square_p($z)) {\n            my $g = Math::GMPz->new(gcd($f1 - Math::GMPz->new(sqrtint($z)), $n));\n\n            if ($g > 1 and $g < $n) {\n                return $g;\n            }\n        }\n\n        last if ($z == 1);\n    }\n\n    return undef;\n}\n\nsub store_factor ($rem, $f, $factors) {\n\n    $f || return;\n\n    if (ref($f) ne 'Math::GMPz') {\n        $f =~ /^[0-9]+\\z/ or return;\n        $f = Math::GMPz->new($f);\n    }\n\n    $f < $$rem or return;\n\n    $$rem % $f == 0 or die 'error';\n\n    if (is_prime($f)) {\n        say(\"`-> prime factor: \", $f);\n        $$rem = check_factor($$rem, $f, $factors);\n    }\n    else {\n        say(\"`-> composite factor: \", $f);\n\n        $$rem /= $f;\n\n        # Try to find a small factor of f\n        my $f_factor = find_small_factors($f, $factors);\n\n        if ($f_factor < $f) {\n            $$rem *= $f_factor;\n        }\n        else {\n\n            # Use SIQS to factorize f\n            find_prime_factors($f, $factors);\n\n            foreach my $p (@$factors) {\n                if ($$rem % $p == 0) {\n                    $$rem = check_factor($$rem, $p, $factors);\n                    last if $$rem == 1;\n                }\n            }\n        }\n    }\n\n    return 1;\n}\n\nsub find_small_factors ($rem, $factors) {\n\n    # Some special-purpose factorization methods to attempt to find small prime factors.\n    # Collect the identified prime factors in the `$factors` array and return 1 if all\n    # prime factors were found, or otherwise the remaining factor.\n\n    my %state = (\n                 cyclotomic_check     => 1,\n                 fast_power_check     => 1,\n                 fast_fibonacci_check => 1,\n                );\n\n    my $len = length($rem);\n\n    my @factorization_methods = (\n\n        sub {\n            say \"=> Sophie Germain method...\";\n            sophie_germain_factor($rem);\n        },\n\n        sub {\n            say \"=> Miller-Rabin method...\";\n            miller_rabin_factor($rem, ($len > 1000) ? 15 : MILLER_RABIN_ITERATIONS);\n        },\n\n        sub {\n            if ($len < 3000) {\n                say \"=> Lucas-Miller method (n+1)...\";\n                lucas_miller_factor($rem, +1, ($len > 1000) ? 10 : LUCAS_MILLER_ITERATIONS);\n            }\n        },\n\n        sub {\n            if ($len < 3000) {\n                say \"=> Lucas-Miller method (n-1)...\";\n                lucas_miller_factor($rem, -1, ($len > 1000) ? 10 : LUCAS_MILLER_ITERATIONS);\n            }\n        },\n\n        sub {\n            say \"=> Phi finder method...\";\n            phi_finder_factor($rem, PHI_FINDER_ITERATIONS);\n        },\n\n        sub {\n            say \"=> Fermat's method...\";\n            fermat_find_factor($rem, FERMAT_ITERATIONS);\n        },\n\n        sub {\n            say \"=> HOLF method...\";\n            holf_find_factor($rem, HOLF_ITERATIONS);\n        },\n\n        sub {\n            say \"=> HOLF method (ntheory)...\";\n            holf_ntheory_find_factor($rem, 2 * HOLF_ITERATIONS);\n        },\n\n        sub {\n            say \"=> Pell method...\";\n            pell_find_factor($rem, PELL_ITERATIONS);\n        },\n\n        sub {\n            say \"=> Pollard p-1 (20K)...\";\n            pollard_pm1_ntheory_factor($rem, 20_000);\n        },\n\n        sub {\n            say \"=> Fermat's little theorem (base 2)...\";\n            FLT_find_factor($rem, 2, ($len > 1000) ? 1e4 : FLT_ITERATIONS);\n        },\n\n        sub {\n            my $len_2 = $len * (log(10) / log(2));\n            my $iter  = ($len_2 * MBE_ITERATIONS > 1_000) ? int(1_000 / $len_2) : MBE_ITERATIONS;\n            if ($iter > 0) {\n                say \"=> MBE method ($iter iter)...\";\n                MBE_find_factor($rem, $iter);\n            }\n        },\n\n        sub {\n            say \"=> Fermat's little theorem (base 3)...\";\n            FLT_find_factor($rem, 3, ($len > 1000) ? 1e4 : FLT_ITERATIONS);\n        },\n\n        sub {\n            $state{fast_fibonacci_check} || return undef;\n            say \"=> Fast Fibonacci check...\";\n            my $f = fast_fibonacci_factor($rem, 2 * logint($rem, 2));\n            $f // do { $state{fast_fibonacci_check} = 0 };\n            $f;\n        },\n\n        sub {\n            $state{cyclotomic_check} || return undef;\n            say \"=> Fast cyclotomic check...\";\n            my $f = cyclotomic_factorization($rem);\n            $f // do { $state{cyclotomic_check} = 0 };\n            $f;\n        },\n\n        sub {\n            say \"=> Pollard rho (10M)...\";\n            pollard_rho_ntheory_factor($rem, int sqrt(1e10));\n        },\n\n        sub {\n            say \"=> Pollard p-1 (500K)...\";\n            pollard_pm1_ntheory_factor($rem, 500_000);\n        },\n\n        sub {\n            say \"=> ECM (600)...\";\n            ecm_find_factor($rem, 600, 20);\n        },\n\n        sub {\n            say \"=> Williams p±1 (500K)...\";\n            williams_pp1_ntheory_factor($rem, 500_000);\n        },\n\n        sub {\n            if ($len < 1000) {\n                say \"=> Chebyshev p±1 (500K)...\";\n                chebyshev_factorization($rem, 500_000, int(rand(1e6)) + 2);\n            }\n        },\n\n        sub {\n            say \"=> Williams p±1 (1M)...\";\n            williams_pp1_ntheory_factor($rem, 1_000_000);\n        },\n\n        sub {\n            if ($len < 1000) {\n                say \"=> Chebyshev p±1 (1M)...\";\n                chebyshev_factorization($rem, 1_000_000, int(rand(1e6)) + 2);\n            }\n        },\n\n        sub {\n            say \"=> ECM (2K)...\";\n            ecm_find_factor($rem, 2000, 10);\n        },\n\n        sub {\n            $state{fast_power_check} || return undef;\n            say \"=> Fast power check...\";\n            my $f = fast_power_check($rem, 500);\n            $f // do { $state{fast_power_check} = 0 };\n            $f;\n        },\n\n        sub {\n            if ($len < 500) {\n                say \"=> Fibonacci p±1 (500K)...\";\n                fibonacci_factorization($rem, 500_000);\n            }\n        },\n\n        sub {\n            say \"=> Pollard rho (12M)...\";\n            pollard_rho_ntheory_factor($rem, int sqrt(1e12));\n        },\n\n        sub {\n            say \"=> Pollard p-1 (5M)...\";\n            pollard_pm1_factorial_find_factor($rem, 5_000_000);\n        },\n\n        sub {\n            say \"=> Williams p±1 (3M)...\";\n            williams_pp1_ntheory_factor($rem, 3_000_000);\n        },\n\n        sub {\n            say \"=> Pollard rho (13M)...\";\n            pollard_rho_ntheory_factor($rem, int sqrt(1e13));\n        },\n\n        sub {\n            say \"=> Williams p±1 (5M)...\";\n            williams_pp1_ntheory_factor($rem, 5_000_000);\n        },\n\n        sub {\n            if ($len > 40) {\n                say \"=> ECM (160K)...\";\n                ecm_find_factor($rem, 160_000, 80);\n            }\n        },\n\n        sub {\n            if ($len > 40) {\n                say \"=> Pollard rho (14M)...\";\n                pollard_rho_ntheory_factor($rem, int sqrt(1e14));\n            }\n        },\n\n        sub {\n            say \"=> Pollard p-1 (8M)...\";\n            pollard_pm1_ntheory_factor($rem, 8_000_000);\n        },\n\n        sub {\n            if ($len < 150) {\n                say \"=> Pollard rho-exp...\";\n                pollard_rho_exp_find_factor($rem, ($len > 50 ? 2 : 1) * 200);\n            }\n        },\n\n        sub {\n            if ($len > 50) {\n                say \"=> Pollard p-1 (10M)...\";\n                pollard_pm1_factorial_find_factor($rem, 10_000_000);\n            }\n        },\n\n        sub {\n            if ($len > 50) {\n                say \"=> Williams p±1 (10M)...\";\n                williams_pp1_ntheory_factor($rem, 10_000_000);\n            }\n        },\n\n        sub {\n            if ($len > 70) {\n                say \"=> Pollard rho (15M)...\";\n                pollard_rho_ntheory_factor($rem, int sqrt(1e15));\n            }\n        },\n\n        sub {\n            if ($len > 70) {\n                say \"=> Pollard p-1 (20M)...\";\n                pollard_pm1_factorial_find_factor($rem, 20_000_000);\n            }\n        },\n\n        sub {\n            if ($len > 70) {\n                say \"=> Williams p±1 (20M)...\";\n                williams_pp1_ntheory_factor($rem, 20_000_000);\n            }\n        },\n\n        sub {\n            if ($len > 70) {\n                say \"=> Pollard rho-exp...\";\n                pollard_rho_exp_find_factor($rem, 1000);\n            }\n        },\n\n        sub {\n            if ($len > 70) {\n                say \"=> Pollard rho (16M)...\";\n                pollard_rho_ntheory_factor($rem, int sqrt(1e16));\n            }\n        },\n\n        sub {\n            if ($len > 70) {\n                say \"=> Pollard p-1 (50M)...\";\n                pollard_pm1_factorial_find_factor($rem, 50_000_000);\n            }\n        },\n\n        sub {\n            if ($len > 70) {\n                say \"=> Pollard p+1 (50M)...\";\n                williams_pp1_ntheory_factor($rem, 50_000_000);\n            }\n        },\n\n        sub {\n            if ($len > 70) {\n                say \"=> Pollard rho (16M)...\";\n                pollard_rho_ntheory_factor($rem, int sqrt(1e16));\n            }\n        },\n    );\n\n  MAIN_LOOP: for (; ;) {\n\n        if ($rem <= 1) {\n            last;\n        }\n\n        if (is_prime($rem)) {\n            push @$factors, $rem;\n            $rem = 1;\n            last;\n        }\n\n        $len = length($rem);\n\n        if ($len >= 25 and $len <= 35) {    # factorize with SIQS directly\n            return $rem;\n        }\n\n        printf(\"\\n[*] Factoring %s (%s digits)...\\n\\n\", ($len > MASK_LIMIT ? \"C$len\" : $rem), $len);\n\n        say \"=> Perfect power check...\";\n\n        if (defined(my $f = check_perfect_power($rem))) {\n            my $exp = 1;\n\n            for (my $t = $f ; $t < $rem ; ++$exp) {\n                $t *= $f;\n            }\n\n            my @r = (is_prime($f) ? $f : factorize($f));\n            push(@$factors, (@r) x $exp);\n            return 1;\n        }\n\n        my $end = $#factorization_methods;\n\n        for (my $i = 0 ; $i <= $end ; ++$i) {\n\n            my $code = $factorization_methods[$i];\n            my $f    = $code->();\n\n            if (store_factor(\\$rem, $f, $factors)) {\n\n                # Move the successful factorization method at the top\n                unshift(@factorization_methods, splice(@factorization_methods, $i, 1));\n\n                next MAIN_LOOP;\n            }\n            else {\n\n                # Move the unsuccessful factorization method at the bottom\n                push @factorization_methods, splice(@factorization_methods, $i, 1);\n                --$i;\n                --$end;\n            }\n        }\n\n        last;\n    }\n\n    return $rem;\n}\n\nsub check_perfect_power ($n) {\n\n    # Check whether n is a perfect and return its perfect root.\n    # Returns undef otherwise.\n\n    if ((my $exp = is_power($n)) > 1) {\n        my $root = Math::GMPz->new(rootint($n, $exp));\n        say \"`-> perfect power: $root^$exp\";\n        return $root;\n    }\n\n    return undef;\n}\n\nsub find_prime_factors ($n, $factors) {\n\n    # Return one or more prime factors of the given number n. Assume\n    # that n is not a prime and does not have very small factors.\n\n    my %factors;\n\n    if (defined(my $root = check_perfect_power($n))) {\n        $factors{$root} = $root;\n    }\n    else {\n        my $digits = length($n);\n\n        say(\"\\n[*] Using SIQS to factorize\" . \" $n ($digits digits)...\\n\");\n\n        my $nf = siqs_choose_nf($n);\n        my @sf = siqs_factorize($n, $nf);\n\n        @factors{@sf} = @sf;\n    }\n\n    foreach my $f (values %factors) {\n        find_all_prime_factors($f, $factors);\n    }\n}\n\nsub find_all_prime_factors ($n, $factors) {\n\n    # Return all prime factors of the given number n.\n    # Assume that n does not have very small factors.\n\n    if (!ref($n)) {\n        $n = Math::GMPz->new($n);\n    }\n\n    my $rem = $n;\n\n    while ($rem > 1) {\n\n        if (is_prime($rem)) {\n            push @$factors, $rem;\n            last;\n        }\n\n        my @new_factors;\n        find_prime_factors($rem, \\@new_factors);\n\n        foreach my $f (@new_factors) {\n\n            $rem != $f     or die 'error';\n            $rem % $f == 0 or die 'error';\n            is_prime($f)   or die 'error';\n\n            $rem = check_factor($rem, $f, $factors);\n\n            last if ($rem == 1);\n        }\n    }\n}\n\nsub special_form_factorization ($n) {\n\n    my %seen_divisor;\n    my @near_power_params;\n    my @diff_powers_params;\n    my @cong_powers_params;\n    my @sophie_params;\n\n    #\n    ## Close to a perfect power\n    #\n\n    my $near_power = sub ($r, $e, $k) {\n        my @factors;\n\n        foreach my $d (divisors($e)) {\n            my $x = $r**$d;\n            foreach my $j (1, -1) {\n\n                my $t = $x - $k * $j;\n                my $g = Math::GMPz->new(gcd($t, $n));\n\n                if ($g > TRIAL_DIVISION_LIMIT and $g < $n and !$seen_divisor{$g}++) {\n                    push @factors, $g;\n                }\n            }\n        }\n\n        @factors;\n    };\n\n    foreach my $j (1 .. NEAR_POWER_ITERATIONS) {\n        foreach my $k (1, -1) {\n            my $u = $k * $j * $j;\n\n            if ($n + $u > 0) {\n                if (my $e = is_power($n + $u)) {\n                    my $r = Math::GMPz->new(rootint($n + $u, $e));\n                    say \"[*] Near power detected: $r^$e \", sprintf(\"%s %s\", ($k == 1) ? ('-', $u) : ('+', -$u));\n                    push @near_power_params, [$r, $e, $j];\n                }\n            }\n        }\n    }\n\n    #\n    ## Difference of powers\n    #\n\n    my $diff_powers = sub ($r1, $e1, $r2, $e2) {\n        my @factors;\n\n        my @d1 = divisors($e1);\n        my @d2 = divisors($e2);\n\n        foreach my $d1 (@d1) {\n            my $x = $r1**$d1;\n            foreach my $d2 (@d2) {\n                my $y = $r2**$d2;\n                foreach my $j (1, -1) {\n\n                    my $t = $x - $j * $y;\n                    my $g = Math::GMPz->new(gcd($t, $n));\n\n                    if ($g > TRIAL_DIVISION_LIMIT and $g < $n and !$seen_divisor{$g}++) {\n                        push @factors, $g;\n                    }\n                }\n            }\n        }\n\n        @factors;\n    };\n\n    my $diff_power_check = sub ($r1, $e1) {\n\n        my $u  = $r1**$e1;\n        my $dx = abs($u - $n);\n\n        if (Math::GMPz::Rmpz_perfect_power_p($dx)) {\n\n            my $e2 = is_power($dx) || 1;\n            my $r2 = Math::GMPz->new(rootint($dx, $e2));\n\n            if ($u > $n) {\n                say \"[*] Difference of powers detected: \", sprintf(\"%s^%s - %s^%s\", $r1, $e1, $r2, $e2);\n            }\n            else {\n                say \"[*] Sum of powers detected: \", sprintf(\"%s^%s + %s^%s\", $r1, $e1, $r2, $e2);\n\n                # Sophie Germain's identity:\n                #   n^4 + 4^(2k+1) = n^4 + 4*(4^(2k)) = n^4 + 4*((2^k)^4)\n\n                if ($r1 == 4 and ($e1 % 2 == 1) and $e2 == 4) {    # n = r1^(2k+1) + r2^4\n                    push @sophie_params, [$r2, Math::GMPz->new(rootint($r1**($e1 - 1), 4))];\n                }\n\n                if ($r2 == 4 and ($e2 % 2 == 1) and $e1 == 4) {    # n = r2^(2k+1) + r1^4\n                    push @sophie_params, [$r1, Math::GMPz->new(rootint($r2**($e2 - 1), 4))];\n                }\n            }\n\n            push @diff_powers_params, [$r1, $e1, $r2, $e2];\n        }\n    };\n\n    # Sum and difference of powers of the form a^k ± b^k, where a and b are small.\n    foreach my $r1 (reverse 2 .. logint($n, 2)) {\n\n        my $t = logint($n, $r1);\n\n        $diff_power_check->(Math::GMPz->new($r1), $t);        # sum of powers\n        $diff_power_check->(Math::GMPz->new($r1), $t + 1);    # difference of powers\n    }\n\n    # Sum and difference of powers of the form a^k ± b^k, where a and b are large.\n    foreach my $e1 (reverse 2 .. logint($n, 2)) {\n\n        my $t = Math::GMPz->new(rootint($n, $e1));\n\n        $diff_power_check->($t,     $e1);                     # sum of powers\n        $diff_power_check->($t + 1, $e1);                     # difference of powers\n    }\n\n    #\n    ## Congruence of powers\n    #\n\n    my $cong_powers = sub ($r, $e1, $k, $e2) {\n\n        my @factors;\n\n        my @divs1 = divisors($e1);\n        my @divs2 = divisors($e2);\n\n        foreach my $d1 (@divs1) {\n            my $x = $r**$d1;\n            foreach my $d2 (@divs2) {\n                my $y = $k**$d2;\n                foreach my $j (-1, 1) {\n\n                    my $t = $x - $j * $y;\n                    my $g = Math::GMPz->new(gcd($t, $n));\n\n                    if ($g > TRIAL_DIVISION_LIMIT and $g < $n and !$seen_divisor{$g}++) {\n\n                        if ($r == $k) {\n                            say \"[*] Congruence of powers: a^$d1 == b^$d2 (mod n) -> $g\";\n                        }\n                        else {\n                            say \"[*] Congruence of powers: $r^$d1 == $k^$d2 (mod n) -> $g\";\n                        }\n\n                        push @factors, $g;\n                    }\n                }\n            }\n        }\n\n        @factors;\n    };\n\n    my @congrunce_range = reverse(2 .. 64);\n\n    my $process_congruence = sub ($root, $e) {\n\n        for my $j (1, 0) {\n\n            my $k = $root + $j;\n            my $u = Math::GMPz::Rmpz_init();\n\n            ref($k)\n              ? Math::GMPz::Rmpz_set($u, $k)\n              : Math::GMPz::Rmpz_set_ui($u, $k);\n\n            Math::GMPz::Rmpz_powm_ui($u, $u, $e, $n);\n\n            foreach my $z ($u, $n - $u) {\n                if (Math::GMPz::Rmpz_perfect_power_p($z)) {\n                    my $t = is_power($z) || 1;\n\n                    my $r1 = rootint($z, $t);\n                    my $r2 = rootint($z, $e);\n\n                    push @cong_powers_params, [Math::GMPz->new($r1), $t, Math::GMPz->new($k), $e];\n                    push @cong_powers_params, [Math::GMPz->new($r2), $e, Math::GMPz->new($k), $e];\n                }\n            }\n        }\n    };\n\n    for my $e (@congrunce_range) {\n        my $root = Math::GMPz->new(rootint($n, $e));\n        $process_congruence->($root, $e);\n    }\n\n    for my $root (@congrunce_range) {\n        my $e = Math::GMPz->new(logint($n, $root));\n        $process_congruence->($root, $e);\n    }\n\n    # Sophie Germain's identity\n    # x^4 + 4y^4 = (x^2 + 2xy + 2y^2) * (x^2 - 2xy + 2y^2)\n    my $sophie = sub ($A, $B) {\n        my @factors;\n\n        foreach my $f (\n#<<<\n            $A*$A + (($B*$B)<<1) - (($A*$B<<1)),\n            $A*$A + (($B*$B)<<1) + (($A*$B)<<1),\n#>>>\n          ) {\n            my $g = Math::GMPz->new(gcd($f, $n));\n\n            if ($g > TRIAL_DIVISION_LIMIT and $g < $n and !$seen_divisor{$g}++) {\n                push @factors, $g;\n            }\n        }\n\n        @factors;\n    };\n\n    my $sophie_check_root = sub ($r1) {\n        {\n            my $x  = 4 * $r1**4;\n            my $dx = $n - $x;\n\n            if (is_power($dx, 4)) {\n                my $r2 = Math::GMPz->new(rootint($dx, 4));\n                say \"[*] Sophie Germain special form detected: $r2^4 + 4*$r1^4\";\n                push @sophie_params, [$r2, $r1];\n            }\n\n        }\n\n        {\n            my $y  = $r1**4;\n            my $dy = $n - $y;\n\n            if (($dy % 4 == 0) and is_power($dy >> 2, 4)) {\n                my $r2 = Math::GMPz->new(rootint($dy >> 2, 4));\n                say \"[*] Sophie Germain special form detected: $r1^4 + 4*$r2^4\";\n                push @sophie_params, [$r1, $r2];\n            }\n        }\n    };\n\n    # Try to find n = x^4 + 4*y^4, for x or y small.\n    foreach my $r1 (map { Math::GMPz->new($_) } 2 .. logint($n, 2)) {\n        $sophie_check_root->($r1);\n    }\n\n    {    # Try to find n = x^4 + 4*y^4 for x and y close to floor(n/5)^(1/4).\n        my $k = Math::GMPz->new(rootint($n / 5, 4));\n\n        for my $j (0 .. 1000) {\n            $sophie_check_root->($k + $j);\n        }\n    }\n\n    my @divisors;\n\n    foreach my $args (@near_power_params) {\n        push @divisors, $near_power->(@$args);\n    }\n\n    foreach my $args (@diff_powers_params) {\n        push @divisors, $diff_powers->(@$args);\n    }\n\n    foreach my $args (@cong_powers_params) {\n        push @divisors, $cong_powers->(@$args);\n    }\n\n    foreach my $args (@sophie_params) {\n        push @divisors, $sophie->(@$args);\n    }\n\n    @divisors = sort { $a <=> $b } @divisors;\n\n    my @factors;\n    foreach my $d (@divisors) {\n        my $g = Math::GMPz->new(gcd($n, $d));\n\n        if ($g > TRIAL_DIVISION_LIMIT and $g < $n) {\n            while ($n % $g == 0) {\n                $n /= $g;\n                push @factors, $g;\n            }\n        }\n    }\n\n    return sort { $a <=> $b } @factors;\n}\n\nsub verify_prime_factors ($n, $factors) {\n\n    Math::GMPz->new(vecprod(@$factors)) == $n or die 'product of factors != n';\n\n    foreach my $p (@$factors) {\n        is_prime($p) or die \"not prime detected: $p\";\n    }\n\n    sort { $a <=> $b } @$factors;\n}\n\nsub fast_trial_factor ($n, $L = 1e5, $R = 1e6) {\n\n    my @factors;\n    my @P = sieve_primes(2, $L);\n\n    my $g = Math::GMPz::Rmpz_init();\n    my $t = Math::GMPz::Rmpz_init();\n\n    while (1) {\n\n        # say \"L = $L with $#P\";\n\n        Math::GMPz::Rmpz_set_str($g, vecprod(@P), 10);\n        Math::GMPz::Rmpz_gcd($g, $g, $n);\n\n        # Early stop when n seems to no longer have small factors\n        if (Math::GMPz::Rmpz_cmp_ui($g, 1) == 0) {\n            last;\n        }\n\n        # Factorize n over primes in P\n        foreach my $p (@P) {\n            if (Math::GMPz::Rmpz_divisible_ui_p($g, $p)) {\n\n                Math::GMPz::Rmpz_set_ui($t, $p);\n                my $valuation = Math::GMPz::Rmpz_remove($n, $n, $t);\n                push @factors, ($p) x $valuation;\n\n                # Stop the loop early when no more primes divide `u` (optional)\n                Math::GMPz::Rmpz_divexact_ui($g, $g, $p);\n                last if (Math::GMPz::Rmpz_cmp_ui($g, 1) == 0);\n            }\n        }\n\n        # Early stop when n has been fully factored\n        if (Math::GMPz::Rmpz_cmp_ui($n, 1) == 0) {\n            last;\n        }\n\n        # Early stop when the trial range has been exhausted\n        if ($L > $R) {\n            last;\n        }\n\n        @P = sieve_primes($L + 1, $L << 1);\n        $L <<= 1;\n    }\n\n    return @factors;\n}\n\nsub factorize ($n) {\n\n    # Factorize the given integer n >= 1 into its prime factors.\n\n    my $orig = Math::GMPz::Rmpz_init_set($n);\n\n    if ($n < 1) {\n        die \"Number needs to be an integer >= 1\";\n    }\n\n    my $len = length($n);\n    printf(\"\\n[*] Factoring %s (%d digits)...\\n\", ($len > MASK_LIMIT ? \"C$len\" : $n), $len);\n\n    return ()   if ($n <= 1);\n    return ($n) if is_prime($n);\n\n    if (my $e = is_power($n)) {\n        my $root = Math::GMPz->new(rootint($n, $e));\n        say \"[*] Perfect power detected: $root^$e\";\n        my @factors = (is_prime($root) ? $root : factorize($root));\n        return verify_prime_factors($n, [(@factors) x $e]);\n    }\n\n    my @divisors;\n\n    if (defined(my $g = sophie_germain_factor($n))) {\n        push @divisors, $g;\n    }\n\n    if (!@divisors) {\n        push @divisors, (($n > ~0) ? special_form_factorization($n) : ());\n    }\n\n    if (!@divisors) {\n        push @divisors, fast_trial_factor($n);\n    }\n\n    if (@divisors) {\n\n        say \"[*] Divisors found so far: \", join(', ', sort { $a <=> $b } @divisors);\n\n        my @composite;\n        my @factors;\n\n        foreach my $d (@divisors) {\n            $d > 1 or next;\n            if (is_prime($d)) {\n                push @factors, $d;\n            }\n            else {\n                push @composite, $d;\n            }\n        }\n\n        push @factors, map { factorize($_) } reverse @composite;\n        my $rem = $orig / Math::GMPz->new(vecprod(@factors));\n\n        if (is_prime($rem)) {\n            push @factors, $rem;\n        }\n        elsif ($rem > 1) {\n            push @factors, factorize($rem);\n        }\n\n        return verify_prime_factors($orig, \\@factors);\n    }\n\n    my ($factors, $rem) = trial_division_small_primes($n);\n\n    if (@$factors) {\n        say \"[*] Prime factors found so far: \", join(', ', @$factors);\n    }\n    else {\n        say \"[*] No small factors found...\";\n    }\n\n    if ($rem != 1) {\n\n        if (LOOK_FOR_SMALL_FACTORS) {\n            say \"[*] Trying to find more small factors...\";\n            $rem = find_small_factors($rem, $factors);\n        }\n        else {\n            say \"[*] Skipping the search for more small factors...\";\n        }\n\n        if ($rem > 1) {\n            find_all_prime_factors($rem, $factors);\n        }\n    }\n\n    return verify_prime_factors($orig, $factors);\n}\n\nif (@ARGV) {\n    my $n = eval { Math::GMPz->new($ARGV[0]) };\n\n    if ($@) {    # evaluate the expression using PARI/GP\n        chomp(my $str = `echo \\Q$ARGV[0]\\E | gp -q -f`);\n        $n = Math::GMPz->new($str);\n    }\n\n    say \"\\nPrime factors: \", join(', ', factorize($n));\n}\nelse {\n    die \"Usage: $0 <N>\\n\";\n}\n"
  },
  {
    "path": "Math/smallest_carmichael_divisible_by_n.pl",
    "content": "#!/usr/bin/perl\n\n# Method for finding the smallest Carmichael number divisible by n.\n\n# See also:\n#   https://oeis.org/A135721\n#   https://oeis.org/A253595\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\n\nsub carmichael_from_multiple ($A, $B, $m, $L, $lo, $k, $callback) {\n\n    # Largest possisble prime factor for Carmichael numbers <= B\n    my $max_p = (1 + sqrtint(8 * $B + 1)) >> 2;\n\n    my $hi = vecmin($max_p, rootint(divint($B, $m), $k));\n\n    if ($lo > $hi) {\n        return;\n    }\n\n    if ($k == 1) {\n\n        $lo = vecmax($lo, cdivint($A, $m));\n        $lo > $hi && return;\n\n        my $t = invmod($m, $L) // return;\n        $t > $hi && return;\n        $t += $L * cdivint($lo - $t, $L) if ($t < $lo);\n\n        for (my $p = $t ; $p <= $hi ; $p += $L) {\n            if ($m % $p != 0 and is_prime($p)) {\n                my $n = $m * $p;\n                if (($n - 1) % ($p - 1) == 0) {\n                    $callback->($n);\n                }\n            }\n        }\n\n        return;\n    }\n\n    foreach my $p (@{primes($lo, $hi)}) {\n\n        $m % $p == 0 and next;\n        gcd($m, $p - 1) == 1 or next;\n\n        __SUB__->($A, $B, $m * $p, lcm($L, $p - 1), $p + 1, $k - 1, $callback);\n    }\n}\n\nsub carmichael_divisible_by ($m) {\n\n    $m >= 1 or return;\n    $m % 2 == 0 and return;\n    is_square_free($m) || return;\n    gcd($m, euler_phi($m)) == 1 or return;\n\n    my $A = vecmax(561, $m);\n    my $B = 2 * $A;\n\n    my $L = vecmax(1, lcm(map { $_ - 1 } factor($m)));\n\n    my @found;\n\n    for (; ;) {\n        for my $k ((is_prime($m) ? 2 : 1) .. 1000) {\n\n            my @P;\n            for (my $p = 3 ; scalar(@P) < $k ; $p = next_prime($p)) {\n                if ($m % $p != 0 and $L % $p != 0) {\n                    push @P, $p;\n                }\n            }\n\n            last if (vecprod(@P, $m) > $B);\n\n            my $callback = sub ($n) {\n                push @found, $n;\n                $B = vecmin($B, $n);\n            };\n\n            carmichael_from_multiple($A, $B, $m, $L, $P[0], $k, $callback);\n        }\n\n        last if @found;\n\n        $A = $B + 1;\n        $B = 2 * $A;\n    }\n\n    vecmin(@found);\n}\n\ncarmichael_divisible_by(3) == 561             or die;\ncarmichael_divisible_by(3 * 5) == 62745       or die;\ncarmichael_divisible_by(7 * 19) == 1729       or die;\ncarmichael_divisible_by(47 * 89) == 62745     or die;\ncarmichael_divisible_by(5 * 47 * 89) == 62745 or die;\ncarmichael_divisible_by(3 * 47 * 89) == 62745 or die;\ncarmichael_divisible_by(3 * 89) == 62745      or die;\n\nsay join(', ', map { carmichael_divisible_by($_) } @{primes(3, 50)});\nsay join(', ', map { carmichael_divisible_by($_) } 1 .. 60);\n\n__END__\n561, 1105, 1729, 561, 1105, 561, 1729, 6601, 2465, 2821, 29341, 6601, 334153, 62745\n561, 561, 1105, 1729, 561, 1105, 62745, 561, 1729, 6601, 2465, 2821, 561, 825265, 29341, 6601, 334153, 62745, 561, 2433601, 74165065\n"
  },
  {
    "path": "Math/smallest_k-gonal_inverse.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 08 March 2018\n# https://github.com/trizen\n\n# Given an integer `n`, find the smallest integer k>=3 such that `n` is a k-gonal number.\n\n# Example:\n#  a(12) = 5 since 12 is a pentagonal number, but not a square or triangular.\n\n# See also:\n#   https://oeis.org/A176774\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse ntheory qw(divisors);\nuse Math::AnyNum qw(:overload);\n\nsub smallest_k_gonal_inverse ($n) {\n\n    my @divisors = divisors(2 * $n);\n\n    shift @divisors;\n    pop @divisors;\n\n    foreach my $d (reverse(@divisors)) {\n\n        my $t = $d - 1;\n        my $k = 2*$n / $d + 2*$d - 4;\n\n        if ($k % $t == 0) {\n            my $z = $k / $t;\n\n            if ($z > 2 && $z < $n) {\n                return $k / $t;\n            }\n        }\n    }\n\n    return $n;\n}\n\nforeach my $n (4000 .. 4030) {\n    say \"a($n) = \", smallest_k_gonal_inverse($n);\n}\n"
  },
  {
    "path": "Math/smallest_k-gonal_inverse_brute_force.pl",
    "content": "#!/usr/bin/perl\n\n# Given an integer `n`, find the smallest integer k>=3 such that `n` is a k-gonal number.\n\n# Example:\n#  a(12) = 5 since 12 is a pentagonal number, but not a square or triangular.\n\n# Based on code by Chai Wah Wu.\n\n# See also:\n#   https://oeis.org/A176774\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload isqrt divmod ipolygonal_root polygonal);\n\nsub polygonal_inverse ($n) {\n    for (my $k = (isqrt(8 * $n + 1) - 1) >> 1 ; $k >= 2 ; --$k) {\n\n        my ($x, $y) = divmod(\n            2 * ($k * ($k - 2) + $n),\n                 $k * ($k - 1)\n        );\n\n        return $x if $y == 0;\n    }\n}\n\nforeach my $i (1 .. 31) {\n\n    my $n = 2**$i + 1;\n    my $k = polygonal_inverse($n);\n    my $d = ipolygonal_root($n, $k);\n\n    say \"2^$i + 1 = P($d, $k)\";\n\n    die 'error' if $n != polygonal($d, $k);\n}\n\n__END__\n2^1 + 1 = P(2, 3)\n2^2 + 1 = P(2, 5)\n2^3 + 1 = P(3, 4)\n2^4 + 1 = P(2, 17)\n2^5 + 1 = P(3, 12)\n2^6 + 1 = P(5, 8)\n2^7 + 1 = P(3, 44)\n2^8 + 1 = P(2, 257)\n2^9 + 1 = P(9, 16)\n2^10 + 1 = P(5, 104)\n2^11 + 1 = P(3, 684)\n2^12 + 1 = P(17, 32)\n2^13 + 1 = P(3, 2732)\n2^14 + 1 = P(5, 1640)\n2^15 + 1 = P(33, 64)\n2^16 + 1 = P(2, 65537)\n2^17 + 1 = P(3, 43692)\n2^18 + 1 = P(65, 128)\n2^19 + 1 = P(3, 174764)\n2^20 + 1 = P(17, 7712)\n2^21 + 1 = P(129, 256)\n2^22 + 1 = P(5, 419432)\n2^23 + 1 = P(3, 2796204)\n2^24 + 1 = P(257, 512)\n2^25 + 1 = P(33, 63552)\n2^26 + 1 = P(5, 6710888)\n2^27 + 1 = P(513, 1024)\n2^28 + 1 = P(17, 1973792)\n2^29 + 1 = P(3, 178956972)\n2^30 + 1 = P(1025, 2048)\n2^31 + 1 = P(3, 715827884)\n"
  },
  {
    "path": "Math/smallest_lucas-carmichael_divisible_by_n.pl",
    "content": "#!/usr/bin/perl\n\n# Method for finding the smallest Lucas-Carmichael number divisible by n.\n\n# See also:\n#   https://oeis.org/A253597\n#   https://oeis.org/A253598\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\n\nsub lucas_carmichael_from_multiple ($A, $B, $m, $L, $lo, $k, $callback) {\n\n    my $hi = vecmin(rootint(divint($B, $m), $k), sqrtint($B));\n\n    if ($lo > $hi) {\n        return;\n    }\n\n    if ($k == 1) {\n\n        $lo = vecmax($lo, cdivint($A, $m));\n        $lo > $hi && return;\n\n        my $t = mulmod(invmod($m, $L) // (return), -1, $L);\n        $t > $hi && return;\n        $t += $L * cdivint($lo - $t, $L) if ($t < $lo);\n\n        for (my $p = $t ; $p <= $hi ; $p += $L) {\n            if ($m % $p != 0 and is_prime($p)) {\n                my $n = $m * $p;\n                if (($n + 1) % ($p + 1) == 0) {\n                    $callback->($n);\n                }\n            }\n        }\n\n        return;\n    }\n\n    foreach my $p (@{primes($lo, $hi)}) {\n\n        $m % $p == 0 and next;\n        gcd($m, $p + 1) == 1 or next;\n\n        __SUB__->($A, $B, $m * $p, lcm($L, $p + 1), $p + 1, $k - 1, $callback);\n    }\n}\n\nsub lucas_carmichael_divisible_by ($m) {\n\n    $m >= 1 or return;\n    $m % 2 == 0 and return;\n    is_square_free($m) || return;\n    gcd($m, divisor_sum($m)) == 1 or return;\n\n    my $A = vecmax(399, $m);\n    my $B = 2 * $A;\n\n    my $L = vecmax(1, lcm(map { $_ + 1 } factor($m)));\n\n    my @found;\n\n    for (; ;) {\n        for my $k ((is_prime($m) ? 2 : 1) .. 1000) {\n\n            my @P;\n            for (my $p = 3 ; scalar(@P) < $k ; $p = next_prime($p)) {\n                if ($m % $p != 0 and $L % $p != 0) {\n                    push @P, $p;\n                }\n            }\n\n            last if (vecprod(@P, $m) > $B);\n\n            my $callback = sub ($n) {\n                push @found, $n;\n                $B = vecmin($B, $n);\n            };\n\n            lucas_carmichael_from_multiple($A, $B, $m, $L, $P[0], $k, $callback);\n        }\n\n        last if @found;\n\n        $A = $B + 1;\n        $B = 2 * $A;\n    }\n\n    vecmin(@found);\n}\n\nlucas_carmichael_divisible_by(1) == 399      or die;\nlucas_carmichael_divisible_by(3) == 399      or die;\nlucas_carmichael_divisible_by(3 * 7) == 399  or die;\nlucas_carmichael_divisible_by(7 * 19) == 399 or die;\n\nsay join(', ', map { lucas_carmichael_divisible_by($_) } @{primes(3, 50)});\nsay join(', ', map { lucas_carmichael_divisible_by($_) } 1 .. 100);\n\n__END__\n399, 935, 399, 935, 2015, 935, 399, 4991, 51359, 2015, 1584599, 20705, 5719, 18095\n399, 399, 935, 399, 935, 2015, 935, 399, 399, 4991, 51359, 2015, 8855, 1584599, 9486399, 20705, 5719, 18095, 2915, 935, 399, 46079, 162687, 2015, 22847, 46079, 16719263, 8855, 12719, 7055, 935, 80189, 189099039, 104663\n"
  },
  {
    "path": "Math/smallest_number_with_at_least_n_divisors.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 15 May 2021\n# https://github.com/trizen\n\n# Generate the smallest number that has at least n divisors.\n\n# See also:\n#   https://oeis.org/A061799 -- Smallest number with at least n divisors.\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse ntheory qw(nth_prime);\nuse Math::AnyNum qw(:overload);\n\nsub smallest_number_with_at_least_n_divisors ($threshold, $least_solution = Inf, $k = 1, $max_a = Inf, $sigma0 = 1, $n = 1) {\n\n    if ($sigma0 >= $threshold) {\n        return $n;\n    }\n\n    my $p = nth_prime($k);\n\n    for (my $a = 1 ; $a <= $max_a ; ++$a) {\n        $n *= $p;\n        last if ($n > $least_solution);\n        $least_solution = __SUB__->($threshold, $least_solution, $k + 1, $a, $sigma0 * ($a + 1), $n);\n    }\n\n    return $least_solution;\n}\n\nsay smallest_number_with_at_least_n_divisors(60);      #=> 5040\nsay smallest_number_with_at_least_n_divisors(1000);    #=> 245044800\n"
  },
  {
    "path": "Math/smallest_number_with_n_divisors.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 15 May 2021\n# https://github.com/trizen\n\n# Generate the smallest number that has exactly n divisors.\n\n# See also:\n#   https://oeis.org/A005179 -- Smallest number with exactly n divisors.\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse ntheory qw(nth_prime);\nuse Math::AnyNum qw(:overload);\n\nsub smallest_number_with_n_divisors ($threshold, $least_solution = Inf, $k = 1, $max_a = Inf, $sigma0 = 1, $n = 1) {\n\n    if ($sigma0 == $threshold) {\n        return $n;\n    }\n\n    if ($sigma0 > $threshold) {\n        return $least_solution;\n    }\n\n    my $p = nth_prime($k);\n\n    for (my $a = 1 ; $a <= $max_a ; ++$a) {\n        $n *= $p;\n        last if ($n > $least_solution);\n        $least_solution = __SUB__->($threshold, $least_solution, $k + 1, $a, $sigma0 * ($a + 1), $n);\n    }\n\n    return $least_solution;\n}\n\nsay smallest_number_with_n_divisors(60);      #=> 5040\nsay smallest_number_with_n_divisors(1000);    #=> 810810000\n"
  },
  {
    "path": "Math/smarandache_function.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 17 September 2016\n# Website: https://github.com/trizen\n\n# A decently efficient algorithm for computing the results of the Kempner-Smarandache function.\n\n# See also: https://projecteuler.net/problem=549\n#           https://en.wikipedia.org/wiki/Kempner_function\n#           https://mathworld.wolfram.com/SmarandacheFunction.html\n\n# ∑S(i) for 2 ≤ i ≤ 10^2 == 2012\n# ∑S(i) for 2 ≤ i ≤ 10^6 == 64938007616\n# ∑S(i) for 2 ≤ i ≤ 10^8 == 476001479068717\n\nuse utf8;\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(vecsum vecmax factor_exp factorialmod is_prime);\n\nbinmode(STDOUT, ':utf8');\n\nmy %cache;\n\nsub smarandache {\n    my ($n) = @_;\n\n    return $n if is_prime($n);\n\n    my @f = factor_exp($n);\n    my $Ω = vecsum(map { $_->[1] } @f);\n\n    (@f == $Ω)\n      && return $f[-1][0];\n\n    if (@f == 1) {\n\n        my $ϕ = $f[0][0];\n\n        ($Ω <= $ϕ)\n          && return $ϕ * $Ω;\n\n        exists($cache{$n})\n          && return $cache{$n};\n\n        my $m = $ϕ * $Ω;\n\n        while (factorialmod($m - $ϕ, $n) == 0) {\n            $m -= $ϕ;\n        }\n\n        return ($cache{$n} = $m);\n    }\n\n    vecmax(map { $_->[1] == 1 ? $_->[0] : smarandache($_->[0]**$_->[1]) } @f);\n}\n\n#\n## Tests\n#\n\n#<<<\nmy @tests = (\n    [40, 5],\n    [72, 6],\n    [1234, 617],\n    [5224832089, 164],\n    [688 * 2**15, 43],\n    [891, 11],\n    [704, 11],\n);\n#>>>\n\nforeach my $test (@tests) {\n    my ($n, $r) = @{$test};\n\n    my $s = smarandache($n);\n\n    say \"S($n) = $s\";\n\n    if ($s != $r) {\n        warn \"\\tHowever, that is incorrect! (expected: $r)\";\n    }\n}\n\nprint \"\\n\";\n\nmy $sum   = 0;\nmy $limit = 10**2;\n\nfor my $n (2 .. $limit) {\n    $sum += smarandache($n);\n}\nsay \"∑S(i) for 2 ≤ i ≤ $limit == $sum\";\n\nif ($limit == 100 and $sum != 2012) {\n    warn \"However, that is incorrect (expected: 2012)!\";\n}\n"
  },
  {
    "path": "Math/smooth_numbers_generalized.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 06 March 2019\n# https://github.com/trizen\n\n# Generalized algorithm for generating numbers that are smooth over a set A of primes, below a given limit.\n\nuse 5.020;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Math::GMPz;\nuse ntheory qw(:all);\n\nsub check_valuation ($n, $p) {\n\n    if ($p == 2) {\n        return valuation($n, $p) < 5;\n    }\n\n    if ($p == 3) {\n        return valuation($n, $p) < 3;\n    }\n\n    if ($p == 7) {\n        return valuation($n, $p) < 3;\n    }\n\n    ($n % $p) != 0;\n}\n\nsub smooth_numbers ($limit, $primes) {\n\n    my @h = (1);\n    foreach my $p (@$primes) {\n\n        say \"Prime: $p\";\n\n        foreach my $n (@h) {\n            if ($n * $p <= $limit and check_valuation($n, $p)) {\n                push @h, $n * $p;\n            }\n        }\n    }\n\n    return \\@h;\n}\n\n#\n# Example for finding numbers `m` such that:\n#     sigma(m) * phi(m) = n^k\n# for some `n` and `k`, with `n > 1` and `k > 1`.\n#\n# See also: https://oeis.org/A306724\n#\n\nsub isok ($n) {\n    is_power(Math::GMPz->new(divisor_sum($n)) * euler_phi($n));\n}\n\nmy @smooth_primes;\n\nforeach my $p (@{primes(4801)}) {\n\n    if ($p == 2) {\n        push @smooth_primes, $p;\n        next;\n    }\n\n    my @f1 = factor($p - 1);\n    my @f2 = factor($p + 1);\n\n    if ($f1[-1] <= 7 and $f2[-1] <= 7) {\n        push @smooth_primes, $p;\n    }\n}\n\nmy $h = smooth_numbers(10**15, \\@smooth_primes);\n\nsay \"\\nFound: \", scalar(@$h), \" terms\";\n\nmy %table;\n\nforeach my $n (@$h) {\n\n    my $p = isok($n);\n\n    if ($p >= 8) {\n        say \"a($p) = $n -> \", join(' * ', map { \"$_->[0]^$_->[1]\" } factor_exp($n));\n        push @{$table{$p}}, $n;\n    }\n}\n\nsay '';\n\nforeach my $k (sort { $a <=> $b } keys %table) {\n    say \"a($k) <= \", vecmin(@{$table{$k}});\n}\n\n__END__\n\n# See: https://oeis.org/A306724\n\na(8) <= 498892319051\na(9) <= 14467877252479\na(10) <= 421652049419104\na(11) <= 12227909433154016\na(12) <= 377536703748630244\na(13) <= 926952707565364023467\n"
  },
  {
    "path": "Math/solutions_to_x_squared_equals_-1_mod_n.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 24 October 2017\n# https://github.com/trizen\n\n# Find all the positive solutions to the quadratic congruence: x^2 = -1 (mod n), where `n` is known.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Quadratic_residue\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(sqrtmod factor_exp chinese mulmod forsetproduct);\n\nsub solve_quadratic_congruence {\n    my ($n) = @_;\n\n    my %table;\n    foreach my $f (factor_exp($n)) {\n        my $pp = $f->[0]**$f->[1];\n        my $r = sqrtmod($pp - 1, $pp) || return;\n        push @{$table{$pp}}, [$r, $pp], [$pp - $r, $pp];\n    }\n\n    my %solutions;\n\n    forsetproduct {\n        undef $solutions{chinese(@_)};\n    } values %table;\n\n    return sort { $a <=> $b } keys %solutions;\n}\n\nforeach my $n (1 .. 1e5) {\n    (my @solutions = solve_quadratic_congruence($n)) || next;\n\n    say \"x^2 = -1 (mod $n); x = { \", join(', ', @solutions), ' }';\n\n    # Verify solutions\n    foreach my $solution (@solutions) {\n        if (mulmod($solution, $solution, $n) != $n - 1) {\n            die \"error for $n: $solution\\n\";\n        }\n    }\n}\n\n__END__\nx^2 = -1 (mod 99850); x = { 29543, 46343, 53507, 70307 }\nx^2 = -1 (mod 99853); x = { 4298, 34107, 65746, 95555 }\nx^2 = -1 (mod 99857); x = { 316, 16054, 83803, 99541 }\nx^2 = -1 (mod 99865); x = { 6763, 33183, 66682, 93102 }\nx^2 = -1 (mod 99874); x = { 42617, 57257 }\nx^2 = -1 (mod 99877); x = { 10118, 89759 }\nx^2 = -1 (mod 99881); x = { 19913, 79968 }\nx^2 = -1 (mod 99901); x = { 34569, 65332 }\nx^2 = -1 (mod 99905); x = { 447, 4217, 14227, 17997, 20428, 24198, 34208, 37978, 61927, 65697, 75707, 79477, 81908, 85678, 95688, 99458 }\nx^2 = -1 (mod 99914); x = { 48155, 51759 }\nx^2 = -1 (mod 99917); x = { 17457, 19894, 80023, 82460 }\nx^2 = -1 (mod 99929); x = { 28615, 71314 }\nx^2 = -1 (mod 99937); x = { 6962, 11069, 88868, 92975 }\nx^2 = -1 (mod 99961); x = { 37804, 62157 }\nx^2 = -1 (mod 99965); x = { 5412, 45398, 54567, 94553 }\nx^2 = -1 (mod 99970); x = { 707, 19287, 26853, 46847, 53123, 73117, 80683, 99263 }\nx^2 = -1 (mod 99973); x = { 14119, 25170, 74803, 85854 }\nx^2 = -1 (mod 99977); x = { 16545, 36384, 63593, 83432 }\nx^2 = -1 (mod 99985); x = { 2302, 37692, 62293, 97683 }\nx^2 = -1 (mod 99986); x = { 11031, 88955 }\nx^2 = -1 (mod 99989); x = { 23040, 76949 }\nx^2 = -1 (mod 99994); x = { 18245, 48879, 51115, 81749 }\n"
  },
  {
    "path": "Math/solutions_to_x_squared_equals_1_mod_n.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 03 October 2017\n# https://github.com/trizen\n\n# Find all the positive solutions to the quadratic congruence: x^2 = 1 (mod n), where `n` is known.\n\n# See also:\n#   https://projecteuler.net/problem=451\n#   https://en.wikipedia.org/wiki/Quadratic_residue\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Test::More;\n\nuse ntheory qw(factor_exp chinese forsetproduct);\n\nplan tests => 8;\n\nsub solve_quadratic_congruence {\n    my ($n) = @_;\n\n    my %table;\n    foreach my $f (factor_exp($n)) {\n        my $pp = $f->[0]**$f->[1];\n\n        if ($pp == 2) {\n            push(@{$table{$pp}}, [1, $pp]);\n        }\n        elsif ($pp == 4) {\n            push(@{$table{$pp}}, [1, $pp], [3, $pp]);\n        }\n        elsif ($pp % 2 == 0) {    # 2^k, where k >= 3\n            push(@{$table{$pp}},\n                [$pp / 2 - 1, $pp], [$pp - 1, $pp],\n                [$pp / 2 + 1, $pp], [$pp + 1, $pp]);\n        }\n        else {                    # odd prime power\n            push(@{$table{$pp}}, [1, $pp], [$pp - 1, $pp]);\n        }\n    }\n\n    my @solutions;\n\n    forsetproduct {\n        push @solutions, chinese(@_);\n    } values %table;\n\n    return sort { $a <=> $b } @solutions;\n}\n\nis(join(' ', solve_quadratic_congruence(15)),   '1 4 11 14');\nis(join(' ', solve_quadratic_congruence(77)),   '1 34 43 76');\nis(join(' ', solve_quadratic_congruence(100)),  '1 49 51 99');\nis(join(' ', solve_quadratic_congruence(175)),  '1 76 99 174');\nis(join(' ', solve_quadratic_congruence(266)),  '1 113 153 265');\nis(join(' ', solve_quadratic_congruence(299)),  '1 116 183 298');\nis(join(' ', solve_quadratic_congruence(48)),   '1 7 17 23 25 31 41 47');\nis(join(' ', solve_quadratic_congruence(1800)), '1 199 251 449 451 649 701 899 901 1099 1151 1349 1351 1549 1601 1799');\n\nsay \"Solutions to x^2 = 1 (mod 5040): {\", join(', ', solve_quadratic_congruence(5040)), '}';\n\n__END__\nSolutions to x^2 = 1 (mod 5040): {1, 71, 449, 559, 631, 881, 1009, 1079, 1441, 1511, 1639, 1889, 1961, 2071, 2449, 2519, 2521, 2591, 2969, 3079, 3151, 3401, 3529, 3599, 3961, 4031, 4159, 4409, 4481, 4591, 4969, 5039}\n"
  },
  {
    "path": "Math/solutions_to_x_squared_equals_a_mod_n.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 27 October 2017\n# https://github.com/trizen\n\n# Find (almost) all the positive solutions to the quadratic congruence: x^2 = a (mod n), where `n` and `a` are known.\n\n# For finding all the solutions for the special case `a = 1`, see:\n#   https://github.com/trizen/perl-scripts/blob/master/Math/solutions_to_x%5E2%20=%201%20(mod%20n).pl\n\n# For finding all the solutions to `x^2 = a (mod n)`, see:\n#   https://github.com/trizen/sidef-scripts/blob/master/Math/square_root_modulo_n.sf\n#   https://github.com/trizen/sidef-scripts/blob/master/Math/square_root_modulo_n_tonelli-shanks.sf\n\n# See also:\n#   https://en.wikipedia.org/wiki/Quadratic_residue\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(sqrtmod factor_exp chinese mulmod forsetproduct);\n\nsub modular_square_root {\n    my ($k, $n) = @_;\n\n    my %table;\n    foreach my $f (factor_exp($n)) {\n        my $pp = $f->[0]**$f->[1];\n        my $r = sqrtmod($k, $pp) || return;\n        push @{$table{$pp}}, [$r, $pp], [$pp - $r, $pp];\n    }\n\n    my %solutions;\n\n    forsetproduct {\n        undef $solutions{chinese(@_)};\n    } values %table;\n\n    return sort { $a <=> $b } keys %solutions;\n}\n\nforeach my $n (2 .. 1000) {\n\n    my $k = 1+int(rand($n));\n    (my @solutions = modular_square_root($k, $n)) || next;\n\n    say \"x^2 = $k (mod $n); x = { \", join(', ', @solutions), ' }';\n\n    # Verify solutions\n    foreach my $solution (@solutions) {\n        if (mulmod($solution, $solution, $n) != $k) {\n            die \"error for $n: $solution\\n\";\n        }\n    }\n}\n\n__END__\nx^2 =  81 (mod 863); x = { 9, 854 }\nx^2 = 459 (mod 865); x = { 247, 272, 593, 618 }\nx^2 = 535 (mod 873); x = { 70, 124, 749, 803 }\nx^2 = 685 (mod 877); x = { 135, 742 }\nx^2 = 388 (mod 879); x = { 55, 238, 641, 824 }\nx^2 = 441 (mod 883); x = { 21, 862 }\nx^2 = 813 (mod 886); x = { 195, 691 }\nx^2 =  83 (mod 887); x = { 227, 660 }\nx^2 = 757 (mod 898); x = { 245, 653 }\nx^2 = 848 (mod 907); x = { 162, 745 }\nx^2 = 259 (mod 919); x = { 190, 729 }\nx^2 = 121 (mod 929); x = { 11, 918 }\nx^2 = 737 (mod 934); x = { 175, 759 }\nx^2 = 509 (mod 935); x = { 38, 72, 302, 412, 523, 633, 863, 897 }\nx^2 = 831 (mod 937); x = { 101, 836 }\nx^2 = 511 (mod 939); x = { 220, 406, 533, 719 }\nx^2 = 841 (mod 940); x = { 29, 159, 311, 441, 499, 629, 781, 911 }\nx^2 = 427 (mod 941); x = { 380, 561 }\nx^2 = 606 (mod 943); x = { 355, 424, 519, 588 }\nx^2 = 865 (mod 954); x = { 127, 233, 721, 827 }\nx^2 = 886 (mod 963); x = { 43, 385, 578, 920 }\nx^2 = 142 (mod 967); x = { 143, 824 }\nx^2 = 547 (mod 982); x = { 283, 699 }\nx^2 = 563 (mod 983); x = { 386, 597 }\nx^2 = 565 (mod 991); x = { 245, 746 }\nx^2 = 866 (mod 997); x = { 350, 647 }\n"
  },
  {
    "path": "Math/solve_congruence_equation_example.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 24 August 2016\n# License: GPLv3\n# Website: https://github.com/trizen\n\n# An example for how to solve a linear congruence equation.\n\n# Solving for x in:\n#    (10^5)x + 19541 = 0    (mod 19543)\n#\n# which is equivalent with:\n#    (10^5)x = -19541       (mod 19543)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(invmod);\n\nmy $k =  10**5;     # coefficient of x\nmy $r = -19541;     # congruent to this\nmy $m =  19543;     # modulo this number\n\nsay \"x = \", (invmod($k, $m) * $r) % $m;\n"
  },
  {
    "path": "Math/solve_cubic_equation.pl",
    "content": "#!/usr/bin/perl\r\n\r\n# Find all the solutions to a cubic equation.\r\n\r\n# See also:\r\n#   https://en.wikipedia.org/wiki/Cubic_equation#General_cubic_formula\r\n\r\nuse 5.020;\r\nuse strict;\r\nuse warnings;\r\n\r\nuse Math::AnyNum qw(:overload cbrt sgn);\r\nuse experimental qw(signatures);\r\n\r\nsub solve_cubic_equation($a,$b,$c,$d) {\r\n\r\n    my $D0 = ($b*$b - 3*$a*$c);\r\n    my $D1 = (2*$b**3 - 9*$a*$b*$c + 27*$a*$a*$d);\r\n\r\n    my @roots;\r\n    my $z = (-1 + sqrt(-3))/2;\r\n\r\n    my $C = cbrt(($D1 - (sgn($D0)||-1)*sqrt($D1*$D1 - 4*$D0**3))/2);\r\n\r\n    foreach my $k (0..2) {\r\n        my $t = ($C * $z**$k);\r\n        my $x = -(($b + $t + $D0/$t))/(3*$a);\r\n        push @roots, $x;\r\n    }\r\n\r\n    return @roots;\r\n}\r\n\r\nsay \":: Solutions to: x^3 + 5*x^2 + 2*x - 8 = 0\";\r\nsay for solve_cubic_equation(1, 5, 2, -8);\r\n\r\nsay \"\\n:: Solutions to: x^3 + 4*x^2 + 7*x + 6 = 0\";\r\nsay for solve_cubic_equation(1, 4, 7, 6);\r\n\r\nsay \"\\n:: Solutions to: -36*x^3 + 8*x^2 - 82*x + 2850986 = 0:\";\r\nsay for solve_cubic_equation(-36, 8, -82, 2850986);\r\n\r\nsay \"\\n:: Solutions to: 15*x^3 - 22*x^2 + 8*x - 7520940423059310542039581 = 0:\";\r\nsay for solve_cubic_equation(15, -22, 8, -7520940423059310542039581);\r\n\r\n__END__\r\n:: Solutions to: x^3 + 5*x^2 + 2*x - 8 = 0\r\n-4+2.12412254817660303603850719702361574078813940692e-58i\r\n-2\r\n1\r\n\r\n:: Solutions to: x^3 + 4*x^2 + 7*x + 6 = 0\r\n-2\r\n-1-1.41421356237309504880168872420969807856967187538i\r\n-1+1.41421356237309504880168872420969807856967187538i\r\n\r\n:: Solutions to: -36*x^3 + 8*x^2 - 82*x + 2850986 = 0:\r\n43\r\n-21.3888888888888888888888888888888888888888888889+37.2053444322316098931489931056362914296357714346i\r\n-21.3888888888888888888888888888888888888888888889-37.2053444322316098931489931056362914296357714346i\r\n\r\n:: Solutions to: 15*x^3 - 22*x^2 + 8*x - 7520940423059310542039581 = 0:\r\n-39721925.7666666666666666666666666666666666666667-68800394.4491263888002422566466396186371117612128i\r\n79443853+7.88093052224943999146836047476866957980682147598e-51i\r\n-39721925.7666666666666666666666666666666666666667+68800394.4491263888002422566466396186371117612128i\r\n"
  },
  {
    "path": "Math/solve_cubic_equation_real.pl",
    "content": "#!/usr/bin/perl\n\n# Find a real solution to a cubic equation, using reduction to a depressed cubic, followed by the Cardano formula.\n\n# Dividing ax^3 + bx^2 + cx + d = 0 by `a` and substituting `t - b/(3a)` for x we get the equation:\n#   t^3 + pt + q = 0\n\n# This allows us to use the Cardano formula to solve for `t`, which gives us:\n#   x = t - b/(3a)\n\n# Example (with x = 79443853):\n#    15 x^3 - 22 x^2 + 8 x - 7520940423059310542039581 = 0\n\n# See also:\n#   https://en.wikipedia.org/wiki/Cubic_function\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload cbrt);\n\nsub solve_cubic_equation ($a, $b, $c, $d) {\n\n    my $p = (3*$a*$c - $b*$b) / (3*$a*$a);\n    my $q = (2 * $b**3 - 9*$a*$b*$c + 27*$a*$a*$d) / (27 * $a**3);\n\n    my $t = (cbrt(-($q/2) + sqrt(($q**2 / 4) + ($p**3 / 27))) +\n             cbrt(-($q/2) - sqrt(($q**2 / 4) + ($p**3 / 27))));\n\n    $t - $b/(3*$a);\n}\n\nsay solve_cubic_equation(15, -22, 8, -7520940423059310542039581);    #=> 79443852.9999999999999999...\n"
  },
  {
    "path": "Math/solve_modular_cubic_equation.pl",
    "content": "#!/usr/bin/perl\r\n\r\n# Author: Trizen\r\n# Date: 04 May 2022\r\n# https://github.com/trizen\r\n\r\n# Solve modular quadratic equations of the form:\r\n#   a*x^3 + b*x^2 + c*x + d == 0 (mod m)\r\n\r\n# Work in progress! Not all solutions are found.\r\n# Sometimes, no solution is found, even if solutions do exist...\r\n\r\n# See also:\r\n#   https://en.wikipedia.org/wiki/Cubic_equation\r\n\r\nuse 5.020;\r\nuse strict;\r\nuse warnings;\r\n\r\nuse ntheory qw(:all);\r\nuse List::Util qw(uniq);\r\nuse Math::AnyNum qw(:overload);\r\nuse experimental qw(signatures);\r\n\r\nsub modular_cubic_equation ($A, $B, $C, $D, $M) {\r\n\r\n    my $D0 = ($B * $B - 3 * $A * $C) % $M;\r\n    my $D1 = (2 * $B**3 - 9 * $A * $B * $C + 27 * $A * $A * $D) % $M;\r\n\r\n    my @S2 = allsqrtmod(($D1**2 - 4 * $D0**3) % (4 * $M), (4 * $M));\r\n    my @S3;\r\n\r\n    foreach my $s2 (@S2) {\r\n        foreach my $r ($D1 + $s2, $D1 - $s2) {\r\n            foreach my $s3 (allrootmod(($r / 2) % $M, 3, $M)) {\r\n                my $nu = -($B + $s3 + $D0 / $s3) % $M;\r\n                my $de = (3 * $A);\r\n\r\n                my $x = ($nu / $de) % $M;\r\n                if (($A * $x**3 + $B * $x**2 + $C * $x + $D) % $M == 0) {\r\n                    push @S3, $x;\r\n                }\r\n            }\r\n        }\r\n    }\r\n\r\n    return sort { $a <=> $b } uniq(@S3);\r\n}\r\n\r\nsay join ' ', modular_cubic_equation(5, 3, -12, -640196464320, 432);        #=> 261\r\nsay join ' ', modular_cubic_equation(1, 1, 1,   -10**10 + 42,  10**10);     #=> 9709005706\r\nsay join ' ', modular_cubic_equation(1, 4, 6,   13 - 10**10,   10**10);     #=> 8614398889\r\nsay join ' ', modular_cubic_equation(1, 1, 1,   -10**10 - 10,  10**10);     #=> 8013600910\r\n"
  },
  {
    "path": "Math/solve_modular_quadratic_equation.pl",
    "content": "#!/usr/bin/perl\r\n\r\n# Author: Trizen\r\n# Date: 04 May 2022\r\n# https://github.com/trizen\r\n\r\n# Solve modular quadratic equations of the form:\r\n#   a*x^2 + b*x + c == 0 (mod m)\r\n\r\n# Solving method:\r\n#   D = b^2 - 4*a*c\r\n#   t^2 == D (mod 4*m)\r\n\r\n# By finding all the solutions to `t`, using `sqrtmod(D, 4*m)`, the candidate values for `x` are given by:\r\n#   x_1 = (-b + t)/(2*a)\r\n#   x_2 = (-b - t)/(2*a)\r\n\r\nuse 5.020;\r\nuse strict;\r\nuse warnings;\r\n\r\nuse ntheory qw(:all);\r\nuse List::Util qw(uniq);\r\nuse Math::AnyNum qw(:overload);\r\nuse experimental qw(signatures);\r\n\r\nsub modular_quadratic_equation ($A, $B, $C, $M) {\r\n\r\n    my $D = ($B * $B - 4 * $A * $C);\r\n\r\n    my @S;\r\n    foreach my $t (allsqrtmod($D % (4 * $M), 4 * $M)) {\r\n        for my $uv ([-$B + $t, 2 * $A], [-$B - $t, 2 * $A]) {\r\n            my ($u, $v) = @$uv;\r\n            my $x = ($u % $v == 0) ? (($u / $v) % $M) : divmod($u, $v, $M);\r\n            if (($A * $x * $x + $B * $x + $C) % $M == 0) {\r\n                push @S, $x;\r\n            }\r\n        }\r\n    }\r\n\r\n    return sort { $a <=> $b } uniq(@S);\r\n}\r\n\r\nsay join ' ', modular_quadratic_equation(1, 1, -10**10 + 8,  10**10);\r\nsay join ' ', modular_quadratic_equation(4, 6, 10 - 10**10,  10**10);\r\nsay join ' ', modular_quadratic_equation(1, 1, -10**10 - 10, 10**10);\r\n\r\n__END__\r\n1810486343 2632873031 7367126968 8189513656\r\n905243171 1316436515 5905243171 6316436515\r\n263226214 1620648089 8379351910 9736773785\r\n"
  },
  {
    "path": "Math/solve_pell_equation.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 31 August 2016\n# Edit: 07 February 2018\n# License: GPLv3\n# https://github.com/trizen\n\n# Find the smallest solution in positive integers to the Pell equation: x^2 - d*y^2 = ±1, where `d` is known.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Pell%27s_equation\n#   https://projecteuler.net/problem=66\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(is_square isqrt);\n\nsub sqrt_convergents {\n    my ($n) = @_;\n\n    my $x = isqrt($n);\n    my $y = $x;\n    my $z = 1;\n\n    my @convergents = ($x);\n\n    do {\n        $y = int(($x + $y) / $z) * $z - $y;\n        $z = int(($n - $y * $y) / $z);\n        push @convergents, int(($x + $y) / $z);\n    } until (($y == $x) && ($z == 1));\n\n    return @convergents;\n}\n\nsub cfrac_denominator {\n    my (@cfrac) = @_;\n\n    my ($f1, $f2) = (0, 1);\n\n    foreach my $n (@cfrac) {\n        ($f1, $f2) = ($f2, $n * $f2 + $f1);\n    }\n\n    return $f1;\n}\n\nsub solve_pell {\n    my ($d) = @_;\n\n    return if is_square($d);\n\n    my ($k, @period) = sqrt_convergents($d);\n\n    my @solutions;\n\n    my $x = cfrac_denominator($k, @period);\n    my $p1 = 4 * $d * ($x * $x + 1);\n\n    if (is_square($p1)) {\n        push @solutions, [$x, isqrt($p1) / (2 * $d)];\n        $x = cfrac_denominator($k, @period, @period);\n    }\n\n    my $p2 = 4 * $d * ($x * $x - 1);\n    push @solutions, [$x, isqrt($p2) / (2 * $d)];\n\n    return @solutions;\n}\n\nforeach my $d (1 .. 30) {\n\n    my @solutions = solve_pell($d);\n\n    foreach my $solution (@solutions) {\n        my ($x, $y) = @$solution;\n        printf(\"x^2 - %2dy^2 = %2d    minimum solution: x=%5s and y=%5s\\n\", $d, $x**2 - $d * $y**2, $x, $y);\n    }\n}\n\n__END__\nx^2 -  2y^2 = -1    minimum solution: x=    1 and y=    1\nx^2 -  2y^2 =  1    minimum solution: x=    3 and y=    2\nx^2 -  3y^2 =  1    minimum solution: x=    2 and y=    1\nx^2 -  5y^2 = -1    minimum solution: x=    2 and y=    1\nx^2 -  5y^2 =  1    minimum solution: x=    9 and y=    4\nx^2 -  6y^2 =  1    minimum solution: x=    5 and y=    2\nx^2 -  7y^2 =  1    minimum solution: x=    8 and y=    3\nx^2 -  8y^2 =  1    minimum solution: x=    3 and y=    1\nx^2 - 10y^2 = -1    minimum solution: x=    3 and y=    1\nx^2 - 10y^2 =  1    minimum solution: x=   19 and y=    6\nx^2 - 11y^2 =  1    minimum solution: x=   10 and y=    3\nx^2 - 12y^2 =  1    minimum solution: x=    7 and y=    2\nx^2 - 13y^2 = -1    minimum solution: x=   18 and y=    5\nx^2 - 13y^2 =  1    minimum solution: x=  649 and y=  180\nx^2 - 14y^2 =  1    minimum solution: x=   15 and y=    4\nx^2 - 15y^2 =  1    minimum solution: x=    4 and y=    1\nx^2 - 17y^2 = -1    minimum solution: x=    4 and y=    1\nx^2 - 17y^2 =  1    minimum solution: x=   33 and y=    8\nx^2 - 18y^2 =  1    minimum solution: x=   17 and y=    4\nx^2 - 19y^2 =  1    minimum solution: x=  170 and y=   39\nx^2 - 20y^2 =  1    minimum solution: x=    9 and y=    2\nx^2 - 21y^2 =  1    minimum solution: x=   55 and y=   12\nx^2 - 22y^2 =  1    minimum solution: x=  197 and y=   42\nx^2 - 23y^2 =  1    minimum solution: x=   24 and y=    5\nx^2 - 24y^2 =  1    minimum solution: x=    5 and y=    1\nx^2 - 26y^2 = -1    minimum solution: x=    5 and y=    1\nx^2 - 26y^2 =  1    minimum solution: x=   51 and y=   10\nx^2 - 27y^2 =  1    minimum solution: x=   26 and y=    5\nx^2 - 28y^2 =  1    minimum solution: x=  127 and y=   24\nx^2 - 29y^2 = -1    minimum solution: x=   70 and y=   13\nx^2 - 29y^2 =  1    minimum solution: x= 9801 and y= 1820\nx^2 - 30y^2 =  1    minimum solution: x=   11 and y=    2\n"
  },
  {
    "path": "Math/solve_pell_equation_fast.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 12 May 2018\n# https://github.com/trizen\n\n# Find the smallest solution in positive integers to the Pell equation: x^2 - d*y^2 = 1, where `d` is known.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Pell%27s_equation\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(idiv isqrt is_square);\n\nsub solve_pell ($n) {\n\n    return () if is_square($n);\n\n    my $x = isqrt($n);\n    my $y = $x;\n    my $z = 1;\n    my $r = $x + $x;\n\n    my ($f1, $f2) = (1, $x);\n\n    for (; ;) {\n\n        $y = $r * $z - $y;\n        $z = idiv($n - $y * $y, $z);\n        $r = idiv($x + $y, $z);\n\n        ($f1, $f2) = ($f2, $r * $f2 + $f1);\n\n        if ($z == 1) {\n\n            my $p = 4 * $n * ($f1 * $f1 - 1);\n\n            if (is_square($p)) {\n                return ($f1, idiv(isqrt($p), 2 * $n));\n            }\n        }\n    }\n}\n\nforeach my $d (1 .. 100) {\n\n    my ($x, $y) = solve_pell($d);\n\n    if (defined($x)) {\n        printf(\"x^2 - %2dy^2 = %2d    minimum solution: x=%15s and y=%15s\\n\", $d, $x**2 - $d * $y**2, $x, $y);\n    }\n}\n"
  },
  {
    "path": "Math/solve_pell_equation_generalized.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 29 May 2018\n# https://github.com/trizen\n\n# Find the smallest solution in positive integers to the generalized Pell equation:\n#\n#       x^2 - d*y^2 = n\n#\n# where `d` and `n` are given.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Pell%27s_equation\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(idiv isqrt is_square irand);\n\nsub solve_pell ($n, $u = 1) {\n\n    return () if is_square($n);\n\n    my $x = isqrt($n);\n    my $y = $x;\n    my $z = 1;\n    my $r = $x + $x;\n\n    my ($f1, $f2) = (1, $x);\n\n    for (1 .. 4 * $x * log($x) + 10) {\n\n        $y = $r * $z - $y;\n        $z = idiv($n - $y * $y, $z) || return;\n        $r = idiv($x + $y, $z);\n\n        ($f1, $f2) = ($f2, $r * $f2 + $f1);\n\n        my $p = ($n * ($f1 * $f1 - $u)) << 2;\n\n        if (is_square($p)) {\n            my $t = isqrt($p) >> 1;\n            $t % $n == 0 || next;\n            return ($f1, idiv($t, $n));\n        }\n    }\n\n    return ();\n}\n\nforeach my $d (1 .. 99) {\n    my ($x, $y) = solve_pell($d, irand(1, 9) * (irand(0, 1) ? 1 : -1));\n\n    if (defined($x)) {\n        printf(\"x^2 - %2dy^2 = %2d    minimum solution: x=%15s and y=%15s\\n\", $d, $x**2 - $d * $y**2, $x, $y);\n    }\n\n}\n\n__END__\nx^2 -  2y^2 =  9    minimum solution: x=              3 and y=              0\nx^2 -  5y^2 =  4    minimum solution: x=              2 and y=              0\nx^2 - 14y^2 = -5    minimum solution: x=              3 and y=              1\nx^2 - 15y^2 =  9    minimum solution: x=              3 and y=              0\nx^2 - 21y^2 = -3    minimum solution: x=              9 and y=              2\nx^2 - 28y^2 =  1    minimum solution: x=            127 and y=             24\nx^2 - 29y^2 = -4    minimum solution: x=              5 and y=              1\nx^2 - 31y^2 = -6    minimum solution: x=              5 and y=              1\nx^2 - 47y^2 =  2    minimum solution: x=              7 and y=              1\nx^2 - 53y^2 = -4    minimum solution: x=              7 and y=              1\nx^2 - 58y^2 = -6    minimum solution: x=             38 and y=              5\nx^2 - 61y^2 =  1    minimum solution: x=     1766319049 and y=      226153980\nx^2 - 67y^2 =  9    minimum solution: x=            131 and y=             16\nx^2 - 68y^2 =  1    minimum solution: x=             33 and y=              4\nx^2 - 69y^2 = -5    minimum solution: x=              8 and y=              1\nx^2 - 71y^2 =  1    minimum solution: x=           3480 and y=            413\nx^2 - 89y^2 = -8    minimum solution: x=              9 and y=              1\nx^2 - 92y^2 =  4    minimum solution: x=             48 and y=              5\nx^2 - 93y^2 =  4    minimum solution: x=             29 and y=              3\nx^2 - 95y^2 =  1    minimum solution: x=             39 and y=              4\nx^2 - 97y^2 =  1    minimum solution: x=       62809633 and y=        6377352\nx^2 - 98y^2 =  1    minimum solution: x=             99 and y=             10\n"
  },
  {
    "path": "Math/solve_pell_equation_simple.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 02 February 2019\n# https://github.com/trizen\n\n# Find the smallest solution in positive integers to Pell's equation: x^2 - d*y^2 = 1, where `d` is known.\n\n# See also:\n#   https://rosettacode.org/wiki/Pell%27s_equation\n#   https://en.wikipedia.org/wiki/Pell%27s_equation\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(is_square isqrt idiv);\nuse experimental qw(signatures);\n\nsub solve_pell ($n, $w = 1) {\n\n    return () if is_square($n);\n\n    my $x = isqrt($n);\n    my $y = $x;\n    my $z = 1;\n    my $r = 2 * $x;\n\n    my ($e1, $e2) = (1, 0);\n    my ($f1, $f2) = (0, 1);\n\n    for (1 .. $n) {\n\n        $y = $r * $z - $y;\n        $z = ($n - $y * $y) / $z;\n        $r = idiv(($x + $y), $z);\n\n        my $A = $e2 + $x * $f2;\n        my $B = $f2;\n\n        if ($z == abs($w) and $A**2 - $n * $B**2 == $w) {\n            return ($A, $B);\n        }\n\n        ($e1, $e2) = ($e2, $r * $e2 + $e1);\n        ($f1, $f2) = ($f2, $r * $f2 + $f1);\n    }\n\n    return ();\n}\n\nforeach my $d(-3, -1, 1, 9) {\n    foreach my $n (61, 109, 181, 277) {\n        my ($x, $y) = solve_pell($n, $d);\n        printf(\"x^2 - %3d*y^2 = %2s for x = %-21s and y = %s\\n\", $n, $x**2 - $n * $y**2, $x, $y);\n    }\n}\n\n__END__\nx^2 -  61*y^2 = -3 for x = 5639                  and y = 722\nx^2 - 109*y^2 = -3 for x = 1399                  and y = 134\nx^2 - 181*y^2 = -3 for x = 11262809              and y = 837158\nx^2 - 277*y^2 = -3 for x = 233                   and y = 14\nx^2 -  61*y^2 = -1 for x = 29718                 and y = 3805\nx^2 - 109*y^2 = -1 for x = 8890182               and y = 851525\nx^2 - 181*y^2 = -1 for x = 1111225770            and y = 82596761\nx^2 - 277*y^2 = -1 for x = 8920484118            and y = 535979945\nx^2 -  61*y^2 =  1 for x = 1766319049            and y = 226153980\nx^2 - 109*y^2 =  1 for x = 158070671986249       and y = 15140424455100\nx^2 - 181*y^2 =  1 for x = 2469645423824185801   and y = 183567298683461940\nx^2 - 277*y^2 =  1 for x = 159150073798980475849 and y = 9562401173878027020\nx^2 -  61*y^2 =  9 for x = 125                   and y = 16\nx^2 - 109*y^2 =  9 for x = 3914405               and y = 374932\nx^2 - 181*y^2 =  9 for x = 43805                 and y = 3256\nx^2 - 277*y^2 =  9 for x = 108581                and y = 6524\n"
  },
  {
    "path": "Math/solve_quadratic_diophantine_reciprocals.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 27 February 2021\n# https://github.com/trizen\n\n# Algorithm for finding primitve solutions (x,y,z) with 1 <= x,y,z <= N and x <= y, to the Diophantine reciprocal equation:\n#   1/x^2 + 1/y^2 = k/z^2\n\n# A solution (x,y,z) is a primitive solution if gcd(x,y,z) = 1.\n\n# It is easy to see that:\n#   (x^2 + y^2)/k = v^4, for some integer v.\n\n# Multiplying both sides by k, we have:\n#   x^2 + y^2 = k * v^4\n\n# By finding integer solutions (x,y) to the above Diophantine equation, we can then compute `z` as:\n#   z = sqrt((x^2 * y^2 * k)/(x^2 + y^2))\n#     = sqrt((x^2 * y^2) / v^4)\n\n# We need to iterate over 1 <= v <= sqrt(N).\n\n# See also:\n#   https://projecteuler.net/problem=748\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nmy %cache;\n\nsub sum_of_two_squares_solutions ($n) {\n\n    $n == 0 and return [0, 0];\n\n    if (exists $cache{$n}) {\n        return @{$cache{$n}};\n    }\n\n    my $prod1 = 1;\n    my $prod2 = 1;\n\n    my @prime_powers;\n\n    foreach my $f (factor_exp($n)) {\n        if ($f->[0] % 4 == 3) {    # p = 3 (mod 4)\n            $f->[1] % 2 == 0 or return;    # power must be even\n            $prod2 = mulint($prod2, powint($f->[0], $f->[1] >> 1));\n        }\n        elsif ($f->[0] == 2) {             # p = 2\n            if ($f->[1] % 2 == 0) {        # power is even\n                $prod2 = mulint($prod2, powint($f->[0], $f->[1] >> 1));\n            }\n            else {                         # power is odd\n                $prod1 = mulint($prod1, $f->[0]);\n                $prod2 = mulint($prod2, powint($f->[0], ($f->[1] - 1) >> 1));\n                push @prime_powers, [$f->[0], 1];\n            }\n        }\n        else {                             # p = 1 (mod 4)\n            $prod1 = mulint($prod1, powint($f->[0], $f->[1]));\n            push @prime_powers, $f;\n        }\n    }\n\n    $prod1 == 1 and return [$prod2, 0];\n    $prod1 == 2 and return [$prod2, $prod2];\n\n    my %table;\n    foreach my $f (@prime_powers) {\n\n        my $pp = powint($f->[0], $f->[1]);\n        my $r  = sqrtmod(-1, $pp);\n\n        if (not defined($r)) {\n            require Math::Sidef;\n            $r = Math::Sidef::sqrtmod(-1, $pp);\n        }\n\n        push @{$table{$pp}}, [$r, $pp], [subint($pp, $r), $pp];\n    }\n\n    my @square_roots;\n\n    forsetproduct {\n        push @square_roots, chinese(@_);\n    } values %table;\n\n    my @solutions;\n\n    foreach my $r (@square_roots) {\n\n        my $s = $r;\n        my $q = $prod1;\n\n        while (mulint($s, $s) > $prod1) {\n            ($s, $q) = (modint($q, $s), $s);\n        }\n\n        push @solutions, [mulint($prod2, $s), mulint($prod2, modint($q, $s))];\n    }\n\n    foreach my $f (@prime_powers) {\n        for (my $i = $f->[1] % 2 ; $i < $f->[1] ; $i += 2) {\n\n            my $sq = powint($f->[0], ($f->[1] - $i) >> 1);\n            my $pp = powint($f->[0], $f->[1] - $i);\n\n            push @solutions, map {\n                [map { vecprod($sq, $prod2, $_) } @$_]\n            } __SUB__->(divint($prod1, $pp));\n        }\n    }\n\n    @{\n        $cache{$n} = [\n            do {\n                my %seen;\n                grep { !$seen{$_->[0]}++ } map {\n                    [sort { $a <=> $b } @$_]\n                } @solutions;\n            }\n        ]\n     };\n}\n\nsub S ($N, $k) {\n\n    my $total = 0;\n    my $limit = sqrtint($N);\n\n    my @solutions;\n\n    foreach my $v (1 .. $limit) {\n\n        my $w = powint($v, 4);\n\n        foreach my $pair (sum_of_two_squares_solutions(mulint($k, $w))) {\n\n            my ($x, $y) = @$pair;\n\n            $y <= $N or next;\n\n            my $t = vecprod($x, $x, $y, $y);\n\n            modint($t, $w) == 0 or next;\n\n            my $z = divint($t, $w);\n\n            if (is_square($z)) {\n\n                $z = sqrtint($z);\n                $z <= $N or next;\n\n                if (gcd($x, $y, $z) == 1) {\n                    push @solutions, [$x, $y, $z];\n                }\n            }\n        }\n    }\n\n    sort { $a->[0] <=> $b->[0] } @solutions;\n}\n\nmy $N = 10000;\nmy $k = 5;\n\nsay <<\"EOT\";\n\n:: Primitve solutions (x,y,z) with 1 <= x,y,z <= $N and x <= y, to equation:\n\n    1/x^2 + 1/y^2 = $k/z^2\nEOT\n\nforeach my $triple (S($N, $k)) {\n    my ($x, $y, $z) = @$triple;\n    say \"($x, $y, $z)\";\n}\n\n__END__\n\n:: Primitve solutions (x,y,z) with 1 <= x,y,z <= 10000 and x <= y, to equation:\n\n    1/x^2 + 1/y^2 = 5/z^2\n\n(1, 2, 2)\n(10, 55, 22)\n(17, 646, 38)\n(26, 377, 58)\n(247, 286, 418)\n(374, 527, 682)\n(407, 3034, 902)\n(551, 1798, 1178)\n(583, 6254, 1298)\n(638, 1769, 1342)\n(902, 3649, 1958)\n(950, 1025, 1558)\n(2015, 9230, 4402)\n(2146, 2183, 3422)\n(2318, 7991, 4978)\n(2378, 2911, 4118)\n(3286, 5353, 6262)\n(5002, 6649, 8938)\n(5135, 7930, 9638)\n"
  },
  {
    "path": "Math/solve_reciprocal_pythagorean_equation.pl",
    "content": "#!/usr/bin/perl\n\n# Find all the primitive solutions to the inverse Pythagorean equation:\n#   1/x^2 + 1/y^2 = 1/z^2\n# such that x <= y and 1 <= x,y,z <= N.\n\n# It can be shown that all the primitive solutions are generated from the following parametric form:\n#\n#   x = 2*a*b*(a^2 + b^2)\n#   y = a^4 - b^4\n#   z = 2*a*b*(a^2 - b^2)\n#\n# where gcd(a, b) = 1 and a+b is odd.\n\n# See also:\n#   https://oeis.org/A341990\n#   https://math.stackexchange.com/questions/2688808/diophantine-equation-of-three-variables\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub S ($N) {\n\n    my @solutions;\n    my $limit = rootint($N, 4);\n\n    foreach my $a (1 .. $limit) {\n        foreach my $b (1 .. $a - 1) {\n\n            ($a + $b) % 2 == 1 or next;\n            gcd($a, $b) == 1   or next;\n\n            my $aa = mulint($a, $a);\n            my $ab = mulint($a, $b);\n            my $bb = mulint($b, $b);\n\n            my $x = vecprod(2, $ab, addint($aa, $bb));\n            my $y = subint(powint($a, 4), powint($b, 4));\n            my $z = vecprod(2, $ab, subint($aa, $bb));\n\n            $x <= $N or next;\n            $y <= $N or next;\n            $z <= $N or next;\n\n            push @solutions, [$x, $y, $z];\n        }\n    }\n\n    sort { $a->[0] <=> $b->[0] } @solutions;\n}\n\nmy $N = 10000;\n\nsay <<\"EOT\";\n\n:: Primitve solutions (x,y,z) with 1 <= x,y,z <= $N and x <= y, to equation:\n\n    1/x^2 + 1/y^2 = 1/z^2\nEOT\n\nforeach my $triple (S($N)) {\n    my ($x, $y, $z) = @$triple;\n    say \"($x, $y, $z)\";\n}\n\n__END__\n\n:: Primitve solutions (x,y,z) with 1 <= x,y,z <= 10000 and x <= y, to equation:\n\n    1/x^2 + 1/y^2 = 1/z^2\n\n(20, 15, 12)\n(136, 255, 120)\n(156, 65, 60)\n(444, 1295, 420)\n(580, 609, 420)\n(600, 175, 168)\n(1040, 4095, 1008)\n(1484, 2385, 1260)\n(1640, 369, 360)\n(2020, 9999, 1980)\n(3060, 6545, 2772)\n(3504, 4015, 2640)\n(3640, 2145, 1848)\n(3660, 671, 660)\n(6540, 9919, 5460)\n(6984, 6305, 4680)\n(7120, 3471, 3120)\n(7140, 1105, 1092)\n"
  },
  {
    "path": "Math/solve_sequence.pl",
    "content": "#!/usr/bin/perl\n\n# Encode a sequence of n numbers into a polynomial of, at most, degree n-1.\n# The polynomial will generate the given sequence of numbers, starting with index 0.\n\n# See also:\n#   https://yewtu.be/watch?v=4AuV93LOPcE\n#   https://en.wikipedia.org/wiki/Polynomial_interpolation\n\nuse 5.014;\nuse warnings;\nuse experimental qw(signatures);\n\nuse Math::Polynomial;\nuse Math::AnyNum qw(:overload :all);\nuse List::Util qw(all);\n\nsub binary_product (@arr) {\n\n    while ($#arr > 0) {\n        push @arr, shift(@arr)->mul(shift(@arr));\n    }\n\n    $arr[0];\n}\n\nsub poly_binomial ($n, $k) {\n    my @terms;\n\n    foreach my $i (0 .. $k - 1) {\n        push @terms, $n;\n        $n = $n->sub_const(1);\n    }\n\n    @terms || return Math::Polynomial->new(1);\n    binary_product(@terms)->div_const(factorial($k));\n}\n\nsub array_differences (@arr) {\n\n    my @result;\n\n    foreach my $i (1 .. $#arr) {\n        CORE::push(@result, $arr[$i] - $arr[$i - 1]);\n    }\n\n    @result;\n}\n\nsub solve_seq (@arr) {\n\n    my $poly = Math::Polynomial->new();\n    my $x    = Math::Polynomial->new(0, 1);\n\n    for (my $k = 0 ; ; ++$k) {\n        $poly += poly_binomial($x, $k)->mul_const($arr[0]);\n        @arr = array_differences(@arr);\n        last if all { $_ == 0 } @arr;\n    }\n\n    $poly;\n}\n\nif (@ARGV) {\n    my @terms = (map { Math::AnyNum->new($_) } grep { /[0-9]/ } map { split(' ') } map { split(/\\s*,\\s*/) } @ARGV);\n    say solve_seq(@terms);\n}\nelse {\n    say solve_seq(map { $_**2 } 0 .. 20);                   # (x^2)\n    say solve_seq(map { faulhaber_sum($_, 2) } 0 .. 20);    # (1/3 x^3 + 1/2 x^2 + 1/6 x)\n}\n"
  },
  {
    "path": "Math/sophie_germain_factorization_method.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 26 July 2019\n# https://github.com/trizen\n\n# A simple factorization method, based on Sophie Germain's identity:\n#   x^4 + 4y^4 = (x^2 + 2xy + 2y^2) * (x^2 - 2xy + 2y^2)\n\n# This method is also effective for numbers of the form: n^4 + 4^(2k+1).\n\n# See also:\n#   https://oeis.org/A227855 -- Numbers of the form x^4 + 4*y^4.\n#   https://www.quora.com/What-is-Sophie-Germains-Identity\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub sophie_germain_factorization ($n, $verbose = 0) {\n\n    if (ref($n) ne 'Math::GMPz') {\n        $n = Math::GMPz->new(\"$n\");\n    }\n\n    my $f = sub ($A, $B) {\n        my @factors;\n\n        foreach my $f (\n            $A**2 + 2 * $B**2 - 2 * $A * $B,\n            $A**2 + 2 * $B**2 + 2 * $A * $B,\n        ) {\n            my $g = Math::GMPz->new(gcd($f, $n));\n\n            if ($g > 1 and $g < $n) {\n                while ($n % $g == 0) {\n                    $n /= $g;\n                    push @factors, $g;\n                }\n            }\n        }\n\n        @factors;\n    };\n\n    my $orig = $n;\n    my @sophie_params;\n\n    my $sophie_check_root = sub ($r1) {\n        {\n            my $x  = 4 * $r1**4;\n            my $dx = $n - $x;\n\n            if (is_power($dx, 4, \\my $r2)) {\n                $r2 = Math::GMPz->new($r2);\n                say \"[*] Sophie Germain special form detected: $r2^4 + 4*$r1^4\" if $verbose;\n                push @sophie_params, [$r2, $r1];\n            }\n\n        }\n\n        {\n            my $y  = $r1**4;\n            my $dy = $n - $y;\n\n            if (($dy % 4 == 0) and is_power($dy >> 2, 4, \\my $r2)) {\n                $r2 = Math::GMPz->new($r2);\n                say \"[*] Sophie Germain special form detected: $r1^4 + 4*$r2^4\" if $verbose;\n                push @sophie_params, [$r1, $r2];\n            }\n        }\n    };\n\n    # Try to find n = x^4 + 4*y^4, for x or y small.\n    foreach my $r (map { Math::GMPz->new($_) } 2 .. logint($n, 2)) {\n        $sophie_check_root->($r);\n    }\n\n    # Try to find n = x^4 + 4*y^4 for x,y close to floor(n/5)^(1/4).\n    my $k = Math::GMPz->new(rootint($n / 5, 4));\n\n    for my $j (0 .. 1000) {\n        $sophie_check_root->($k + $j);\n    }\n\n    my @factors;\n\n    foreach my $args (@sophie_params) {\n        push @factors, $f->(@$args);\n    }\n\n    push @factors, $orig / vecprod(@factors);\n    return sort { $a <=> $b } @factors;\n}\n\nif (@ARGV) {\n    say join ', ', sophie_germain_factorization($ARGV[0], 1);\n    exit;\n}\n\nsay join ' * ', sophie_germain_factorization(powint(43,        4) + 4 * powint(372485613, 4));\nsay join ' * ', sophie_germain_factorization(powint(372485613, 4) + 4 * powint(97,        4));\nsay join ' * ', sophie_germain_factorization(powint(372485613, 4) + 4 * powint(372485629, 4));\nsay join ' * ', sophie_germain_factorization(powint(372485629, 4) + 4 * powint(372485511, 4));\n\nsay '';\n\nsay join ' * ', sophie_germain_factorization(powint(4, 117) + powint(53,  4));\nsay join ' * ', sophie_germain_factorization(powint(4, 213) + powint(240, 4));\nsay join ' * ', sophie_germain_factorization(powint(4, 251) + powint(251, 4));\n\n__END__\n277491031750210669 * 277491095817736105\n138745459629795665 * 138745604154213509\n138745543811525897 * 693727695218548205\n138745455904945045 * 693727455337830721\n\n166153499473114453560556010453601017 * 166153499473114514665395754616490745\n13164036458569648337239753460419861813422875717854660184319779072 * 13164036458569648337239753460497746266300898132282617629258080512\n3618502788666131106986593281521497099061968496512379043906292883903830095385 * 3618502788666131106986593281521497141767405545090156208559806116590740633113\n"
  },
  {
    "path": "Math/sorting_algorithms.pl",
    "content": "#!/usr/bin/perl\n\nuse 5.016;\nuse List::Util qw(min max shuffle);\n\n############################################\n# For performance comparisons, execute:\n############################################\n##    perl -d:NYTProf sorting_algorithms.pl\n##    nytprofhtml --open -m\n############################################\n\n{\n    # LAZY SORT\n    sub lazysort {\n        my (@A) = @_;\n\n        my $end = $#A;\n\n        while (1) {\n            my $swapped;\n            for (my $i = 0 ; $i < $end ; $i++) {\n                if ($A[$i] > $A[$i + 1]) {\n                    @A[$i + 1, $i] = @A[$i, $i + 1];\n                    $swapped //= 1;\n                    $i++;\n                }\n            }\n            $swapped || return \\@A;\n        }\n    }\n}\n\n{\n    # QUICK SORT\n    sub quick_sort {\n        my (@a) = @_;\n        @a < 2 ? @a : do {\n            my $p = pop @a;\n            __SUB__->(grep $_ < $p, @a), $p, __SUB__->(grep $_ >= $p, @a);\n          }\n    }\n}\n\n{\n    # QUICK SORT (with partition)\n    sub _partition {\n        my ($array, $first, $last) = @_;\n        my $i     = $first;\n        my $j     = $last - 1;\n        my $pivot = $array->[$last];\n      SCAN: {\n            do {\n                # $first <= $i <= $j <= $last - 1\n                # Point 1.\n                # Move $i as far as possible.\n                while ($array->[$i] <= $pivot) {\n                    $i++;\n                    last SCAN if $j < $i;\n                }\n\n                # Move $j as far as possible.\n                while ($array->[$j] >= $pivot) {\n                    $j--;\n                    last SCAN if $j < $i;\n                }\n\n                # $i and $j did not cross over, so swap a low and a high value.\n                @$array[$j, $i] = @$array[$i, $j];\n            } while (--$j >= ++$i);\n        }\n\n        # $first - 1 <= $j < $i <= $last\n        # Point 2.\n        # Swap the pivot with the first larger element (if there is one)\n        if ($i < $last) {\n            @$array[$last, $i] = @$array[$i, $last];\n            ++$i;\n        }\n\n        # Point 3.\n        return ($i, $j);    # The new bounds exclude the middle.\n    }\n\n    sub _quicksort_recurse {\n        my ($array, $first, $last) = @_;\n        if ($last > $first) {\n            my ($first_of_last, $last_of_first) = _partition($array, $first, $last);\n            __SUB__->($array, $first,         $last_of_first);\n            __SUB__->($array, $first_of_last, $last);\n        }\n    }\n\n    sub _quicksort_iterate {\n        my ($array, $first, $last) = @_;\n        my @stack = ($first, $last);\n        do {\n            if ($last > $first) {\n                my ($last_of_first, $first_of_last) = _partition $array, $first, $last;\n\n                # Larger first.\n                if ($first_of_last - $first > $last - $last_of_first) {\n                    push @stack, $first, $first_of_last;\n                    $first = $last_of_first;\n                }\n                else {\n                    push @stack, $last_of_first, $last;\n                    $last = $first_of_last;\n                }\n            }\n            else {\n                ($first, $last) = splice @stack, -2, 2;    # Double pop.\n            }\n        } while @stack;\n    }\n\n    sub quick_sort2 {\n        my @arr = @_;\n\n        # The recursive version is bad with BIG lists\n        # because the function call stack gets REALLY deep.\n        _quicksort_recurse(\\@arr, 0, $#arr);\n    }\n\n    sub quick_sort3 {\n        my @arr = @_;\n        _quicksort_iterate(\\@arr, 0, $#arr);\n    }\n\n}\n\n{\n    # BUBBLE SORT\n    sub bubble_sort {\n        for my $i (0 .. $#_) {\n            for my $j ($i + 1 .. $#_) {\n                $_[$j] < $_[$i] && do {\n                    @_[$i, $j] = @_[$j, $i];\n                };\n            }\n        }\n    }\n}\n\n{\n    # BUBBLE SORT SMART\n    sub bubblesmart {\n        my @array = @_;\n        my $start = 0;         # The start index of the bubbling scan.\n        my $i     = $#array;\n        while (1) {\n            my $new_start;     # The new start index of the bubbling scan.\n            my $new_end = 0;   # The new end index of the bubbling scan.\n            for (my $j = $start || 1 ; $j <= $i ; $j++) {\n                if ($array[$j - 1] > $array[$j]) {\n                    @array[$j, $j - 1] = @array[$j - 1, $j];\n                    $new_end = $j - 1;\n                    $new_start = $j - 1 unless defined $new_start;\n                }\n            }\n            last unless defined $new_start;    # No swaps: we're done.\n            $i     = $new_end;\n            $start = $new_start;\n        }\n    }\n}\n\n{\n    # COCKTAIL SORT\n    sub cocktailSort {                         #( A : list of sortable items ) defined as:\n        my @A       = @_;\n        my $swapped = 1;\n        while ($swapped == 1) {\n            $swapped = 0;\n            for (my $i = 0 ; $i < ($#A - 1) ; $i += 1) {\n\n                if ($A[$i] > $A[$i + 1]) {     # test whether the two\n                                               # elements are in the wrong\n                                               # order\n                    ($A[$i + 1], $A[$i]) = ($A[$i], $A[$i + 1]);    # let the two elements\n                                                                    # change places\n                    $swapped = 1;\n                }\n            }\n            if ($swapped == 0) {\n\n                # we can exit the outer loop here if no swaps occurred.\n            }\n            else {\n                $swapped = 0;\n                for (my $i = ($#A - 1) ; $i > 0 ; $i -= 1) {\n\n                    if ($A[$i] > $A[$i + 1]) {\n                        ($A[$i + 1], $A[$i]) = ($A[$i], $A[$i + 1]);\n                        $swapped = 1;\n                    }\n                }\n            }\n\n            #  if no elements have been swapped,\n            #  then the list is sorted\n        }\n        return (@A);\n    }\n}\n\n{\n    # COMB SORT\n    sub combSort {\n        my @arr   = @_;\n        my $gap   = @arr;\n        my $swaps = 1;\n        while ($gap > 1 or $swaps) {\n            $gap /= 1.25 if $gap > 1;\n            $swaps = 0;\n            foreach my $i (0 .. $#arr - $gap) {\n                if ($arr[$i] > $arr[$i + $gap]) {\n                    @arr[$i, $i + $gap] = @arr[$i + $gap, $i];\n                    $swaps = 1;\n                }\n            }\n        }\n        return @arr;\n    }\n}\n\n{\n    # GNOME SORT\n    sub gnome_sort {\n        my @a = @_;\n\n        my $size = scalar(@a);\n        my $i    = 1;\n        my $j    = 2;\n        while ($i < $size) {\n            if ($a[$i - 1] <= $a[$i]) {\n                $i = $j;\n                $j++;\n            }\n            else {\n                @a[$i, $i - 1] = @a[$i - 1, $i];\n                $i--;\n                if ($i == 0) {\n                    $i = $j;\n                    $j++;\n                }\n            }\n        }\n        return @a;\n    }\n}\n\n{\n    # HEAP SORT\n    sub heap_sort {\n        my (@list) = @_;\n        my $count = scalar @list;\n        _heapify($count, \\@list);\n\n        my $end = $count - 1;\n        while ($end > 0) {\n            @list[0, $end] = @list[$end, 0];\n            _sift_down(0, $end - 1, \\@list);\n            --$end;\n        }\n    }\n\n    sub _heapify {\n        my ($count, $list) = @_;\n        my $start = ($count - 2) / 2;\n        while ($start >= 0) {\n            _sift_down($start, $count - 1, $list);\n            --$start;\n        }\n    }\n\n    sub _sift_down {\n        my ($start, $end, $list) = @_;\n\n        my $root = $start;\n        while ($root * 2 + 1 <= $end) {\n            my $child = $root * 2 + 1;\n            ++$child if $child + 1 <= $end and $$list[$child] < $$list[$child + 1];\n            if ($$list[$root] < $$list[$child]) {\n                @$list[$root, $child] = @$list[$child, $root];\n                $root = $child;\n            }\n            else {\n                return;\n            }\n        }\n    }\n}\n\n{\n    # HEAP SORT (2)\n    sub heap_sort2 {\n        use integer;\n        my (@array) = @_;\n        for (my $index = 1 + @array / 2 ; $index-- ;) {\n            _heapify2(\\@array, $index);\n        }\n        for (my $last = @array ; --$last ;) {\n            @array[0, $last] = @array[$last, 0];\n            _heapify2(\\@array, 0, $last);\n        }\n    }\n\n    sub _heapify2 {\n        use integer;\n        my ($array, $index, $last) = @_;\n        $last = @$array unless defined $last;\n        my $swap = $index;\n        my $high = $index * 2 + 1;\n        for (my $try = $index * 2 ; $try < $last and $try <= $high ; ++$try) {\n            $swap = $try if $$array[$try] > $$array[$swap];\n        }\n        unless ($swap == $index) {\n\n            # The heap is in disorder: must reshuffle.\n            @{$array}[$swap, $index] = @{$array}[$index, $swap];\n            __SUB__->($array, $swap, $last);\n        }\n    }\n}\n\n{\n    # MERGE SORT (simple)\n    sub merge_sort {\n        my @x = @_;\n        return @x if @x < 2;\n        my $m = int @x / 2;\n        my @a = __SUB__->(@x[0 .. $m - 1]);\n        my @b = __SUB__->(@x[$m .. $#x]);\n        for (@x) {\n            $_ =\n                !@a            ? shift @b\n              : !@b            ? shift @a\n              : $a[0] <= $b[0] ? shift @a\n              :                  shift @b;\n        }\n        @x;\n    }\n}\n\n{\n    # MERGE SORT (recursive + iterative)\n    {\n        my @work;    # A global work array.\n\n        sub _merge {\n            my ($array, $first, $middle, $last) = @_;\n            my $n = $last - $first + 1;\n\n            # Initialize work with relevant elements from the array.\n            for (my $i = $first, my $j = 0 ; $i <= $last ;) {\n                $work[$j++] = $array->[$i++];\n            }\n\n            # Now do the actual merge. Proceed through the work array\n            # and copy the elements in order back to the original array\n            # $i is the index for the merge result, $j is the index in\n            # first half of the working copy, $k the index in the second half.\n            $middle = int(($first + $last) / 2) if $middle > $last;\n            my $n1 = $middle - $first + 1;    # The size of the 1st half.\n            for (my $i = $first, my $j = 0, my $k = $n1 ; $i <= $last ; $i++) {\n                $array->[$i] =\n                    $j < $n1 && ($k == $n || $work[$j] < $work[$k])\n                  ? $work[$j++]\n                  : $work[$k++];\n            }\n        }\n    }\n\n    sub _mergesort_recurse {\n        my ($array, $first, $last) = @_;\n        if ($last > $first) {\n            my $middle = int(($last + $first) / 2);\n            __SUB__->($array, $first,      $middle);\n            __SUB__->($array, $middle + 1, $last);\n            _merge($array, $first, $middle, $last);\n        }\n    }\n\n    sub merge_sort2 {\n        my @array = @_;\n        _mergesort_recurse(\\@array, 0, $#array);\n    }\n\n    {\n\n        sub merge_sort3 {\n            my @array = @_;\n            my $N     = @array;\n            my $Nt2   = $N * 2;    # N times 2.\n            my $Nm1   = $N - 1;    # N minus 1.\n            for (my $size = 2 ; $size < $Nt2 ; $size *= 2) {\n                for (my $first = 0 ; $first < $N ; $first += $size) {\n                    my $last = $first + $size - 1;\n                    _merge(\\@array, $first, int(($first + $last) / 2), $last < $N ? $last : $Nm1);\n                }\n            }\n        }\n    }\n}\n\n{\n    # SHELL SORT\n    sub shell_sort {\n        my (@a, $h, $i, $j, $k) = @_;\n        for ($h = @a ; $h = int $h / 2 ;) {\n            for $i ($h .. $#a) {\n                $k = $a[$i];\n                for ($j = $i ; $j >= $h and $k < $a[$j - $h] ; $j -= $h) {\n                    $a[$j] = $a[$j - $h];\n                }\n                $a[$j] = $k;\n            }\n        }\n        @a;\n    }\n}\n\n{\n    # SHELL SORT (2)\n    sub shell_sort2 {\n        my @array = @_;\n        my $i;    # The initial index for the bubbling scan.\n        my $j;    # The running index for the bubbling scan.\n        my $shell = (2 << log(scalar @array) / log(2)) - 1;\n        do {\n            $shell = int(($shell - 1) / 2);\n            for ($i = $shell ; $i < @array ; $i++) {\n                for ($j = $i - $shell ; $j >= 0 && $array[$j] > $array[$j + $shell] ; $j -= $shell) {\n                    @array[$j, $j + $shell] = @array[$j + $shell, $j];\n                }\n            }\n        } while $shell > 1;\n    }\n}\n\n{\n    # SELECTION SORT\n    sub selection_sort {\n        my @a = @_;\n        foreach my $i (0 .. $#a - 1) {\n            my $min = $i + 1;\n            $a[$_] < $a[$min] and $min = $_ foreach ($min .. $#a);\n            @a[$i, $min] = @a[$min, $i] if $a[$i] > $a[$min];\n        }\n        return @a;\n    }\n}\n\n{\n    # SELECTION SORT (2)\n    sub selection_sort2 {\n        my @array = @_;\n        my $i;    # The starting index of a minimum-finding scan.\n        my $j;    # The running index of a minimum-finding scan.\n        for ($i = 0 ; $i < $#array ; $i++) {\n            my $m = $i;            # The index of the minimum element.\n            my $x = $array[$m];    # The minimum value.\n            for ($j = $i + 1 ; $j < @array ; $j++) {\n                ($m, $x) = ($j, $array[$j])    # Update minimum.\n                  if $array[$j] < $x;\n            }\n\n            # Swap if needed.\n            @array[$m, $i] = @array[$i, $m] unless $m == $i;\n        }\n    }\n}\n\n{\n    # INSERTION SORT\n    sub insertion_sort {\n        my (@list) = @_;\n        foreach my $i (1 .. $#list) {\n            my $j = $i;\n            my $k = $list[$i];\n            while ($j > 0 and $k < $list[$j - 1]) {\n                $list[$j] = $list[$j - 1];\n                --$j;\n            }\n            $list[$j] = $k;\n        }\n        return @list;\n    }\n}\n\n{\n    # INSERTION SORT (2)\n    sub insertion_sort2 {\n        my @array = @_;\n        my $i;    # The initial index for the minimum element.\n        my $j;    # The running index for the minimum-finding scan.\n        for ($i = 0 ; $i < $#array ; $i++) {\n            my $m = $i;            # The final index for the minimum element.\n            my $x = $array[$m];    # The minimum value.\n            for ($j = $i + 1 ; $j < @array ; $j++) {\n                ($m, $x) = ($j, $array[$j])    # Update minimum.\n                  if $array[$j] < $x;\n            }\n\n            # The double-splice simply moves the $m-th element to be\n            # the $i-th element. Note: splice is O(N), not O(1).\n            # As far as the time complexity of the algorithm is concerned\n            # it makes no difference whether we do the block movement\n            # using the preceding loop or using splice(). Still, splice()\n            # is faster than moving the block element by element.\n            splice @array, $i, 0, splice @array, $m, 1 if $m > $i;\n        }\n    }\n}\n\n{\n    # STRAND SORT\n    sub _strand_merge {\n        my ($x, $y) = @_;\n        my @out;\n        while (@$x and @$y) {\n            my $cmp = $$x[-1] <=> $$y[-1];\n            if    ($cmp == 1)  { unshift @out, pop @$x }\n            elsif ($cmp == -1) { unshift @out, pop @$y }\n            else               { splice @out, 0, 0, pop @$x, pop @$y }\n        }\n        return @$x, @$y, @out;\n    }\n\n    sub _strand {\n        my $x = shift;\n        my @out = shift @$x // return;\n        if (@$x) {\n            for (-@$x .. -1) {\n                if ($x->[$_] >= $out[-1]) {\n                    push @out, splice @$x, $_, 1;\n                }\n            }\n        }\n        return @out;\n    }\n\n    sub strand_sort {\n        my @x = @_;\n        my @out;\n        while (my @strand = _strand(\\@x)) {\n            @out = _strand_merge(\\@out, \\@strand);\n        }\n        @out;\n    }\n}\n\n{\n    # NIGHT SORT\n    sub night_sort {\n        my (@arr) = @_;\n\n        my $max = 0;\n        my $min = 0;\n\n        my @indices = $max;\n\n        my $swapped;\n        foreach my $i (1 .. $#arr) {\n            my $cmp = $arr[$i - 1] <=> $arr[$i];\n\n            push @indices,\n                $cmp == -1 ? $indices[-1] + 1\n              : $cmp == 1 ? do { $swapped //= 1; $indices[-1] - 1 }\n              :             $indices[-1];\n\n            $min = $indices[-1] if $indices[-1] < $min;\n            $max = $indices[-1] if $indices[-1] > $max;\n        }\n        unless ($swapped) {\n            return @arr;\n        }\n\n        my @fetch;\n        for my $i ($min .. $max) {\n            for my $j (0 .. $#indices) {\n                if ($indices[$j] == $i) {\n                    push @fetch, $j;\n                }\n            }\n        }\n        __SUB__->(@arr[@fetch]);\n    }\n}\n\n{\n    # MORNING SORT\n    sub morning_sort {\n        my (@arr) = @_;\n        @arr < 2 ? @arr : do {\n            my $p = splice(@arr, int rand @arr, 1);\n            __SUB__->(grep $_ <= $p, @arr), $p, __SUB__->(grep $_ > $p, @arr);\n          }\n    }\n}\n\n{\n    # AFTERNOON SORT\n    sub afternoon_sort {\n        my (@arr) = @_;\n\n        my @new;\n        for (@arr) {\n            push @{$new[int(log($_ + 1) * (10**(1 + int(log($_ + 1) / log(10)))))]}, $_;\n        }\n\n        map { defined($_) ? @{$_} : () } @new;\n    }\n}\n\n{\n    # SAC SORT\n    sub sac_sort {\n        my (@arr, @sac) = @_;\n\n        @arr > 1 || return @arr;\n\n        for (@arr) {\n            my $i = 0;\n            for (; $i <= $#sac ; ++$i) {\n                last if $sac[$i] > $_;\n            }\n            splice @sac, $i, 0, $_;\n        }\n\n        @sac;\n    }\n}\n\n{\n    # SAC SORT SMART\n    sub sac_sort_smart {\n        my (@arr, @sac) = @_;\n\n        @arr > 1 || return @arr;\n\n        my $c1 = 0;\n        my $c2 = 1;\n        my $j  = 0;\n\n        for (@arr) {\n            if ($c1 < $c2) {\n                my $i = 0;\n                for (; $i <= $#sac ; ++$i) {\n                    last if $sac[$i] > $_;\n                    ++$c1;\n                }\n                splice @sac, $i, 0, $_;\n            }\n            else {\n                my $i = $j;\n                for (; $i > 0 ; --$i) {\n                    last if $sac[$i - 1] < $_;\n                    ++$c2;\n                }\n                splice @sac, $i, 0, $_;\n            }\n            ++$j;\n        }\n\n        @sac;\n    }\n}\n\n{\n    # COUNTING SORT\n    sub counting_sort {\n        my ($a, $min, $max) = @_;\n\n        my @cnt = (0) x ($max - $min + 1);\n        $cnt[$_ - $min]++ foreach @$a;\n\n        my $i = $min;\n        @$a = map { ($i++) x $_ } @cnt;\n    }\n}\n\n{\n    # BEADSORT\n    sub beadsort {\n        my @data = @_;\n\n        my @columns;\n        my @rows;\n\n        for my $datum (@data) {\n            for my $column (0 .. $datum - 1) {\n                ++$rows[$columns[$column]++];\n            }\n\n        }\n\n        return reverse @rows;\n    }\n}\n\n{\n    # PANCAKE\n    sub pancake {\n        my @x = @_;\n        for my $idx (0 .. $#x - 1) {\n            my $min = $idx;\n            $x[$min] > $x[$_] and $min = $_ for $idx + 1 .. $#x;\n\n            next if $x[$min] == $x[$idx];\n\n            @x[$min .. $#x] = reverse @x[$min .. $#x] if $x[$min] != $x[-1];\n            @x[$idx .. $#x] = reverse @x[$idx .. $#x];\n        }\n        @x;\n    }\n}\n\n{\n    # BINSERTION SORT\n    sub _binary_search {\n        my ($array_ref, $value, $left, $right, $middle) = @_;\n\n        $array_ref->[$middle = int(($right + $left) / 2)] > $value\n          ? ($right = $middle - 1)\n          : ($left = $middle + 1)\n          while ($left <= $right);\n\n        ++$middle while ($array_ref->[$middle] < $value);\n\n        $middle;\n    }\n\n    sub binsertion_sort {\n        my (@list) = @_;\n\n        foreach my $i (1 .. $#list) {\n            if ((my $k = $list[$i]) < $list[$i - 1]) {\n                splice(@list, $i, 1);\n                splice(@list, _binary_search(\\@list, $k, 0, $i - 1), 0, $k);\n            }\n        }\n\n        return @list;\n    }\n}\n\n##########################################################\n\n# Random\nmy @arr = map { int(rand($_) + rand(500)) } 0 .. 500;\n\n# Reversed\n#my @arr = reverse(0..500);\n\n# Sorted\n#my @arr = (0..500);\n\n##########################################################\n\nafternoon_sort(map $_, @arr);\n#beadsort(map $_, @arr);        # pretty slow\nbinsertion_sort(map $_, @arr);\nbubble_sort(map $_, @arr);\nbubblesmart(map $_, @arr);\ncocktailSort(map $_, @arr);\ncombSort(map $_, @arr);\ncounting_sort([map $_, @arr], min(@arr), max(@arr));\ngnome_sort(map $_, @arr);\nheap_sort(map $_, @arr);\nheap_sort2(map $_, @arr);\ninsertion_sort(map $_, @arr);\ninsertion_sort2(map $_, @arr);\nlazysort(map $_, @arr);\nmerge_sort(map $_, @arr);\nmerge_sort2(map $_, @arr);\nmerge_sort3(map $_, @arr);\nmorning_sort(map $_, @arr);\n#night_sort(map $_, @arr);       # too sleepy\npancake(map $_, @arr);\nquick_sort(map $_, @arr);\nquick_sort2(map $_, @arr);\nquick_sort3(map $_, @arr);\nsac_sort(map $_, @arr);\nsac_sort_smart(map $_, @arr);\nselection_sort(map $_, @arr);\nselection_sort2(map $_, @arr);\nshell_sort(map $_, @arr);\nshell_sort2(map $_, @arr);\nstrand_sort(map $_, @arr);\n"
  },
  {
    "path": "Math/sphere_volume.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n\n# OLD: V = (4/3) * PI * r^3\n# NEW: V = r^4 * PI / (r * 0.75)\n#\n#      V = r^2 * PI * (r * 0.75^(-1))\n#      0.75^(-1) = 1.33333\n#\n#      r^2 * r = r^3\n#      1.33333 = 4/3\n#      V = r^3 * PI * (4/3)\n\nuse 5.010;\n\nsay sprintf('%.32f', ($ARGV[0] || die \"usage: $0 <r>\\n\")**4 * atan2('inf', 0) * 2 / ($ARGV[0] * 0.75)) =~ /^(.+?\\.\\d+?)(?=0*$)/;\n"
  },
  {
    "path": "Math/sqrt_mod_p_tonelli-shanks_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 11 April 2018\n# https://github.com/trizen\n\n# An efficient implementation of the Tonelli-Shanks algorithm, using Math::GMPz.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\nuse experimental qw(signatures);\n\nsub sqrt_mod ($n, $p) {\n\n    if (ref($n) ne 'Math::GMPz') {\n        $n = Math::GMPz::Rmpz_init_set_str(\"$n\", 10);\n    }\n\n    if (ref($p) ne 'Math::GMPz') {\n        $p = Math::GMPz::Rmpz_init_set_str(\"$p\", 10);\n    }\n\n    my $q = Math::GMPz::Rmpz_init_set($p);\n\n    if (Math::GMPz::Rmpz_divisible_p($n, $p)) {\n        Math::GMPz::Rmpz_mod($q, $q, $p);\n        return $q;\n    }\n\n    if (Math::GMPz::Rmpz_legendre($n, $p) != 1) {\n        die \"Not a quadratic residue!\";\n    }\n\n    if (Math::GMPz::Rmpz_tstbit($p, 1) == 1) {    # p = 3 (mod 4)\n\n        # q = n ^ ((p+1) / 4) (mod p)\n        Math::GMPz::Rmpz_add_ui($q, $q, 1);       # q = p+1\n        Math::GMPz::Rmpz_fdiv_q_2exp($q, $q, 2);  # q = (p+1)/4\n        Math::GMPz::Rmpz_powm($q, $n, $q, $p);    # q = n^q (mod p)\n        return $q;\n    }\n\n    Math::GMPz::Rmpz_sub_ui($q, $q, 1);           # q = p-1\n\n    # Factor out 2^s from q\n    my $s = Math::GMPz::Rmpz_remove($q, $q, Math::GMPz::Rmpz_init_set_ui(2));\n\n    # Search for a non-residue mod p by picking the first w such that (w|p) is -1\n    my $w = 2;\n    while (Math::GMPz::Rmpz_ui_kronecker($w, $p) != -1) { ++$w }\n    $w = Math::GMPz::Rmpz_init_set_ui($w);\n\n    Math::GMPz::Rmpz_powm($w, $w, $q, $p);    # w = w^q (mod p)\n    Math::GMPz::Rmpz_add_ui($q, $q, 1);       # q = q+1\n    Math::GMPz::Rmpz_fdiv_q_2exp($q, $q, 1);  # q = (q+1) / 2\n\n    my $n_inv = Math::GMPz::Rmpz_init();\n\n    Math::GMPz::Rmpz_powm($q, $n, $q, $p);    # q = n^q (mod p)\n    Math::GMPz::Rmpz_invert($n_inv, $n, $p);\n\n    my $y = Math::GMPz::Rmpz_init();\n\n    for (; ;) {\n        Math::GMPz::Rmpz_powm_ui($y, $q, 2, $p);    # y = q^2 (mod p)\n        Math::GMPz::Rmpz_mul($y, $y, $n_inv);\n        Math::GMPz::Rmpz_mod($y, $y, $p);           # y = y * n^-1 (mod p)\n\n        my $i = 0;\n\n        for (; Math::GMPz::Rmpz_cmp_ui($y, 1) ; ++$i) {\n            Math::GMPz::Rmpz_powm_ui($y, $y, 2, $p);    #  y = y ^ 2 (mod p)\n        }\n\n        if ($i == 0) {                                # q^2 * n^-1 = 1 (mod p)\n            return $q;\n        }\n\n        if ($s - $i == 1) {\n            Math::GMPz::Rmpz_mul($q, $q, $w);\n        }\n        else {\n            Math::GMPz::Rmpz_powm_ui($y, $w, 1 << ($s - $i - 1), $p);\n            Math::GMPz::Rmpz_mul($q, $q, $y);\n        }\n\n        Math::GMPz::Rmpz_mod($q, $q, $p);\n    }\n\n    return $q;\n}\n\nsay sqrt_mod('1030',                                               '10009');\nsay sqrt_mod('44402',                                              '100049');\nsay sqrt_mod('665820697',                                          '1000000009');\nsay sqrt_mod('881398088036',                                       '1000000000039');\nsay sqrt_mod('41660815127637347468140745042827704103445750172002', '100000000000000000000000000000000000000000000000577');\n"
  },
  {
    "path": "Math/square_divisors.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 30 July 2018\n# https://github.com/trizen\n\n# Generate all the square divisors of a given number.\n\nuse 5.036;\nuse ntheory qw(:all);\n\nsub square_divisors($n) {\n\n    my @d = (1);\n    my @pp = grep { $_->[1] > 1 } factor_exp($n);\n\n    foreach my $pp (@pp) {\n        my ($p, $e) = @$pp;\n\n        my @t;\n        for (my $i = 2 ; $i <= $e ; $i += 2) {\n            my $u = powint($p, $i);\n            push @t, map { mulint($_, $u) } @d;\n        }\n\n        push @d, @t;\n    }\n\n    return sort { $a <=> $b } @d;\n}\n\nsay join(', ', square_divisors(3628800));\n"
  },
  {
    "path": "Math/square_product_subsets.pl",
    "content": "#!/usr/bin/perl\n\n# Find subsets of integers whose product is a square, using Gaussian elimination on a GF(2) matrix of vector exponents.\n\n# Code inspired by:\n#   https://github.com/martani/Quadratic-Sieve/blob/master/matrix.c\n\n# See also:\n#   https://btravers.weebly.com/uploads/6/7/2/9/6729909/quadratic_sieve_slides.pdf\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse List::Util qw(first);\nuse ntheory qw(factor_exp prime_count);\nuse Math::AnyNum qw(:overload is_square);\n\nsub getbit ($n, $k) {\n    ($n >> $k) & 1;\n}\n\nsub setbit ($n, $k) {\n    (1 << $k) | $n;\n}\n\nsub gaussian_elimination ($rows, $n) {\n\n    my @A = @$rows;\n    my $m = $#A;\n    my @I = map { 1 << $_ } 0 .. $m;\n\n    my $nrow = -1;\n    my $mcol = $m < $n ? $m : $n;\n\n    foreach my $col (0 .. $mcol) {\n        my $npivot = -1;\n\n        foreach my $row ($nrow+1 .. $m) {\n            if (getbit($A[$row], $col)) {\n                $npivot = $row;\n                $nrow++;\n                last;\n            }\n        }\n\n        next if ($npivot == -1);\n\n        if ($npivot != $nrow) {\n            @A[$npivot, $nrow] = @A[$nrow, $npivot];\n            @I[$npivot, $nrow] = @I[$nrow, $npivot];\n        }\n\n        foreach my $row ($nrow+1 .. $m) {\n            if (getbit($A[$row], $col)) {\n                $A[$row] ^= $A[$nrow];\n                $I[$row] ^= $I[$nrow];\n            }\n        }\n    }\n\n    return (\\@A, \\@I);\n}\n\nsub exponents_signature(@factors) {\n    my $sig = 0;\n\n    foreach my $p (@factors) {\n        if ($p->[1] & 1) {\n            $sig = setbit($sig, prime_count($p->[0]) - 1);\n        }\n    }\n\n    return $sig;\n}\n\nsub find_square_subsets(@set) {\n\n    my $max_prime = 2;\n\n    my @rows;\n    foreach my $n (@set) {\n        my @factors = factor_exp($n);\n\n        if (@factors) {\n            my $p = $factors[-1][0];\n            $max_prime = $p if ($p > $max_prime);\n        }\n\n        push @rows, exponents_signature(@factors);\n    }\n\n    if (@rows < prime_count($max_prime)) {\n        push @rows, (0) x (prime_count($max_prime) - @rows);\n    }\n\n    my ($A, $I) = gaussian_elimination(\\@rows, prime_count($max_prime) - 1);\n\n    my $LR = (first { $A->[-$_] } 1 .. @$A) - 1;\n\n    my @square_subsets;\n\n    foreach my $solution (@{$I}[@$I - $LR .. $#$I]) {\n\n        my @terms;\n        my $prod = 1;\n\n        foreach my $i (0 .. $#set) {\n            if (getbit($solution, $i)) {\n\n                $prod *= $set[$i];\n\n                push @terms, $set[$i];\n                push @square_subsets, [@terms] if is_square($prod);\n            }\n        }\n    }\n\n    return @square_subsets;\n}\n\nmy @Q = (\n    10, 97, 24, 35, 75852, 54, 12, 13, 11,\n    33, 37, 48, 57, 58, 63, 68, 377, 15,\n    20, 26, 7, 3, 17, 29, 43, 41, 4171, 78\n);\n\n#@Q = (10, 24, 35, 52, 54, 78);\n\nmy @S = find_square_subsets(@Q);\n\nforeach my $solution (@S) {\n    say join(' ', @$solution);\n}\n\n__END__\n12 48\n10 24 35 12 63\n24 54\n24 12 13 58 377\n10 24 15\n10 24 12 20\n24 12 13 26\n10 24 35 12 7\n12 3\n68 17\n24 12 58 29\n75852 43\n12 11 33\n97 75852 4171\n24 13 78\n"
  },
  {
    "path": "Math/square_root_convergents.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 17 April 2018\n# https://github.com/trizen\n\n# Find the convergents of a square root for a non-square positive integer.\n\n# See also:\n#    https://en.wikipedia.org/wiki/Pell%27s_equation#Solutions\n#    https://en.wikipedia.org/wiki/Continued_fraction#Infinite_continued_fractions\n#    https://www.wolframalpha.com/input/?i=Convergents%5BSqrt%5B61%5D%5D\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload isqrt idiv);\n\nsub sqrt_convergents ($n, $callback, $count = 10) {\n    my $x = isqrt($n);\n    my $y = $x;\n    my $z = 1;\n\n    my $r = $x + $x;\n\n    my ($e1, $e2) = (1, 0);\n    my ($f1, $f2) = (0, 1);\n\n    for (1 .. $count) {\n        $y = $r * $z - $y;\n        $z = idiv($n - $y * $y, $z);\n        $r = idiv($x + $y, $z);\n\n        $callback->($e2 + $x * $f2, $f2);\n\n        ($f1, $f2) = ($f2, $r * $f2 + $f1);\n        ($e1, $e2) = ($e2, $r * $e2 + $e1);\n\n        $y = $x if ($z == 1);\n    }\n}\n\nsqrt_convergents(61, sub ($n, $d) {\n        printf(\"%20s / %-20s =~ %s\\n\", $n, $d, ($n / $d)->as_dec);\n}, 20)\n\n__END__\n           7 / 1                    =~ 7\n           8 / 1                    =~ 8\n          39 / 5                    =~ 7.8\n         125 / 16                   =~ 7.8125\n         164 / 21                   =~ 7.80952380952380952380952380952380952380952380952\n         453 / 58                   =~ 7.81034482758620689655172413793103448275862068966\n        1070 / 137                  =~ 7.8102189781021897810218978102189781021897810219\n        1523 / 195                  =~ 7.81025641025641025641025641025641025641025641026\n        5639 / 722                  =~ 7.81024930747922437673130193905817174515235457064\n       24079 / 3083                 =~ 7.81024975673045734674018812844631852092118066818\n       29718 / 3805                 =~ 7.81024967148488830486202365308804204993429697766\n      440131 / 56353                =~ 7.81024967614856351924476070484268805564921122212\n      469849 / 60158                =~ 7.81024967585358555803051963163669004953622128395\n     2319527 / 296985               =~ 7.81024967590955772177045978753135680253211441655\n     7428430 / 951113               =~ 7.81024967590601747636716142035699228167420695543\n     9747957 / 1248098              =~ 7.81024967590685987799035011673762797472634360443\n    26924344 / 3447309              =~ 7.81024967590662745927330564216900776808809422074\n    63596645 / 8142716              =~ 7.81024967590666308391450714970287555159728031777\n    90520989 / 11590025             =~ 7.81024967590665248780740334900054141384509524354\n   335159612 / 42912791             =~ 7.81024967590665449842216042298437312082544339752\n"
  },
  {
    "path": "Math/square_root_method.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 01 October 2016\n# Website: https://github.com/trizen\n\n# Approximate the square root of a number.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload);\n\nsub square_root {\n    my ($n) = @_;\n\n    my $eps = 10**-($Math::AnyNum::PREC >> 2);\n\n    my $m = $n;\n    my $r = 0.0;\n\n    while (abs($m - $r) > $eps) {\n        $m = ($m + $r) / 2;\n        $r = $n / $m;\n    }\n\n    $r;\n}\n\nsay square_root(1234);\n"
  },
  {
    "path": "Math/square_root_modulo_n_tonelli-shanks.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 30 October 2017\n# https://github.com/trizen\n\n# Find all the solutions to the congruence equation:\n#   x^2 = a (mod n)\n\n# Defined for any values of `a` and `n` for which `kronecker(a, n) = 1`.\n\n# When `kronecker(a, n) != 1`, for example:\n#\n#   a = 472\n#   n = 972\n#\n# which represents:\n#   x^2 = 472 (mod 972)\n#\n# this algorithm may fail find all the solutions, although there exist four solutions in this case:\n#   x = {38, 448, 524, 934}\n\n# Code inspired from:\n#   https://github.com/Magtheridon96/Square-Root-Modulo-N\n\nuse 5.020;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse List::Util qw(uniq);\nuse ntheory qw(factor_exp is_prime chinese forsetproduct);\nuse Math::AnyNum qw(:overload kronecker powmod invmod valuation ipow mulmod);\n\nsub tonelli_shanks ($n, $p) {\n\n    $n %= $p;\n\n    my $q = $p - 1;\n    my $s = valuation($q, 2);\n\n    $s == 1\n      and return powmod($n, ($p + 1) >> 2, $p);\n\n    $q >>= $s;\n\n    my $z = 1;\n    for (my $i = 2 ; $i < $p ; ++$i) {\n        if (kronecker($i, $p) == -1) {\n            $z = $i;\n            last;\n        }\n    }\n\n    my $c = powmod($z, $q, $p);\n    my $r = powmod($n, ($q + 1) >> 1, $p);\n    my $t = powmod($n, $q, $p);\n\n    while (($t - 1) % $p != 0) {\n\n        my $k = 1;\n        my $v = mulmod($t, $t, $p);\n\n        for (my $i = 1 ; $i < $s ; ++$i) {\n            if (($v - 1) % $p == 0) {\n                $k = powmod($c, 1 << ($s - $i - 1), $p);\n                $s = $i;\n                last;\n            }\n            $v = mulmod($v, $v, $p);\n        }\n\n        $r = mulmod($r, $k, $p);\n        $c = mulmod($k, $k, $p);\n        $t = mulmod($t, $c, $p);\n    }\n\n    return $r;\n}\n\nsub sqrt_mod_n ($a, $n) {\n\n    $a %= $n;\n\n    return 0 if ($a == 0);\n\n    if (($n & ($n - 1)) == 0) {    # n is a power of 2\n\n        if ($a % 8 == 1) {\n\n            my $k = valuation($n, 2);\n\n            $k == 1 and return (1);\n            $k == 2 and return (1, 3);\n            $k == 3 and return (1, 3, 5, 7);\n\n            if ($a == 1) {\n                return (1, ($n >> 1) - 1, ($n >> 1) + 1, $n - 1);\n            }\n\n            my @roots;\n\n            foreach my $s (sqrt_mod_n($a, $n >> 1)) {\n                my $i = ((($s * $s - $a) >> ($k - 1)) % 2);\n                my $r = ($s + ($i << ($k - 2)));\n                push(@roots, $r, $n - $r);\n            }\n\n            return uniq(@roots);\n        }\n\n        return;\n    }\n\n    if (is_prime($n)) {    # n is a prime\n        kronecker($a, $n) == 1 or return;\n        my $r = tonelli_shanks($a, $n);\n        return ($r, $n - $r);\n    }\n\n    my @pe = factor_exp($n);    # factorize `n` into prime powers\n\n    if (@pe == 1) {             # `n` is an odd prime power\n\n        my $p = Math::AnyNum->new($pe[0][0]);\n\n        kronecker($a, $p) == 1 or return;\n\n        my $r = tonelli_shanks($a, $p);\n        my ($r1, $r2) = ($r, $n - $r);\n\n        my $pk = $p;\n        my $pi = $p * $p;\n\n        for (1 .. $pe[0][1]-1) {\n\n            my $x = $r1;\n            my $y = invmod(2, $pk) * invmod($x, $pk);\n\n            $r1 = ($pi + $x - $y * ($x * $x - $a + $pi)) % $pi;\n            $r2 = ($pi - $r1);\n\n            $pk *= $p;\n            $pi *= $p;\n        }\n\n        return ($r1, $r2);\n    }\n\n    my @chinese;\n\n    foreach my $f (@pe) {\n        my $m = ipow($f->[0], $f->[1]);\n        my @r = sqrt_mod_n($a, $m);\n        push @chinese, [map { [$_, $m] } @r];\n    }\n\n    my @roots;\n\n    forsetproduct {\n        push @roots, chinese(@_);\n    } @chinese;\n\n    return uniq(@roots);\n}\n\nsay join(' ', sqrt_mod_n(993, 2048));    #=> 369 1679 655 1393\nsay join(' ', sqrt_mod_n(441, 920));     #=> 761 481 209 849 531 251 899 619 301 21 669 389 71 711 439 159\nsay join(' ', sqrt_mod_n(841, 905));     #=> 391 876 29 514\nsay join(' ', sqrt_mod_n(289, 992));     #=> 417 513 975 79 913 17 479 575\nsay join(' ', sqrt_mod_n(472, 972));     #=> 448 524\n\n# The algorithm works for arbitrary large integers\nsay join(' ', sqrt_mod_n(13**18 * 5**7 - 1, 13**18 * 5**7));    #=> 633398078861605286438568 2308322911594648160422943 6477255756527023177780182 8152180589260066051764557\n"
  },
  {
    "path": "Math/squarefree_almost_prime_divisors.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 29 March 2021\n# https://github.com/trizen\n\n# Generate all the squarefree k-almost prime divisors of n.\n\nuse 5.020;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub squarefree_almost_prime_divisors ($n, $k) {\n\n    if ($k == 0) {\n        return (1);\n    }\n\n    my @factor_exp  = factor_exp($n);\n    my @factors     = map { $_->[0] } @factor_exp;\n    my %valuations  = map { @$_ } @factor_exp;\n    my $factors_end = $#factors;\n\n    if ($k == 1) {\n        return @factors;\n    }\n\n    my @list;\n\n    sub ($m, $k, $i = 0) {\n\n        if ($k == 1) {\n\n            my $L = divint($n, $m);\n\n            foreach my $j ($i .. $factors_end) {\n                my $q = $factors[$j];\n                last if ($q > $L);\n                push(@list, mulint($m, $q));\n            }\n\n            return;\n        }\n\n        my $L = rootint(divint($n, $m), $k);\n\n        foreach my $j ($i .. $factors_end - 1) {\n            my $q = $factors[$j];\n            last if ($q > $L);\n            __SUB__->(mulint($m, $q), $k - 1, $j + 1);\n        }\n    }->(1, $k);\n\n    sort { $a <=> $b } @list;\n}\n\nmy $n = vecprod(@{primes(15)});\n\nforeach my $k (0 .. prime_omega($n)) {\n    my @divisors = squarefree_almost_prime_divisors($n, $k);\n    printf(\"%2d-squarefree almost prime divisors of %s: [%s]\\n\", $k, $n, join(', ', @divisors));\n}\n\n__END__\n 0-squarefree almost prime divisors of 30030: [1]\n 1-squarefree almost prime divisors of 30030: [2, 3, 5, 7, 11, 13]\n 2-squarefree almost prime divisors of 30030: [6, 10, 14, 15, 21, 22, 26, 33, 35, 39, 55, 65, 77, 91, 143]\n 3-squarefree almost prime divisors of 30030: [30, 42, 66, 70, 78, 105, 110, 130, 154, 165, 182, 195, 231, 273, 286, 385, 429, 455, 715, 1001]\n 4-squarefree almost prime divisors of 30030: [210, 330, 390, 462, 546, 770, 858, 910, 1155, 1365, 1430, 2002, 2145, 3003, 5005]\n 5-squarefree almost prime divisors of 30030: [2310, 2730, 4290, 6006, 10010, 15015]\n 6-squarefree almost prime divisors of 30030: [30030]\n"
  },
  {
    "path": "Math/squarefree_almost_primes_from_factor_list.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 29 March 2021\n# https://github.com/trizen\n\n# Generate all the squarefree k-almost primes <= n, using a given list of prime factors.\n\nuse 5.020;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub squarefree_almost_primes ($n, $k, $factors) {\n\n    my $factors_end = $#{$factors};\n\n    if ($k == 0) {\n        return (1);\n    }\n\n    if ($k == 1) {\n        return @$factors;\n    }\n\n    my @list;\n\n    sub ($m, $k, $i = 0) {\n\n        if ($k == 1) {\n\n            my $L = divint($n, $m);\n\n            foreach my $j ($i .. $factors_end) {\n                my $q = $factors->[$j];\n                last if ($q > $L);\n                push(@list, mulint($m, $q));\n            }\n\n            return;\n        }\n\n        my $L = rootint(divint($n, $m), $k);\n\n        foreach my $j ($i .. $factors_end - 1) {\n            my $q = $factors->[$j];\n            last if ($q > $L);\n            __SUB__->(mulint($m, $q), $k - 1, $j + 1);\n        }\n    }->(1, $k);\n\n    sort { $a <=> $b } @list;\n}\n\nmy $n       = 1e6;                  # limit\nmy @factors = @{primes(17)};        # prime list\n\nforeach my $k (0 .. scalar(@factors)) {\n    my @divisors = squarefree_almost_primes($n, $k, \\@factors);\n    printf(\"%2d-squarefree almost primes <= %s: [%s]\\n\", $k, $n, join(', ', @divisors));\n}\n\n__END__\n 0-squarefree almost primes <= 1000000: [1]\n 1-squarefree almost primes <= 1000000: [2, 3, 5, 7, 11, 13, 17]\n 2-squarefree almost primes <= 1000000: [6, 10, 14, 15, 21, 22, 26, 33, 34, 35, 39, 51, 55, 65, 77, 85, 91, 119, 143, 187, 221]\n 3-squarefree almost primes <= 1000000: [30, 42, 66, 70, 78, 102, 105, 110, 130, 154, 165, 170, 182, 195, 231, 238, 255, 273, 286, 357, 374, 385, 429, 442, 455, 561, 595, 663, 715, 935, 1001, 1105, 1309, 1547, 2431]\n 4-squarefree almost primes <= 1000000: [210, 330, 390, 462, 510, 546, 714, 770, 858, 910, 1122, 1155, 1190, 1326, 1365, 1430, 1785, 1870, 2002, 2145, 2210, 2618, 2805, 3003, 3094, 3315, 3927, 4641, 4862, 5005, 6545, 7293, 7735, 12155, 17017]\n 5-squarefree almost primes <= 1000000: [2310, 2730, 3570, 4290, 5610, 6006, 6630, 7854, 9282, 10010, 13090, 14586, 15015, 15470, 19635, 23205, 24310, 34034, 36465, 51051, 85085]\n 6-squarefree almost primes <= 1000000: [30030, 39270, 46410, 72930, 102102, 170170, 255255]\n 7-squarefree almost primes <= 1000000: [510510]\n"
  },
  {
    "path": "Math/squarefree_almost_primes_in_range.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 10 March 2021\n# Edit: 14 March 2026\n# https://github.com/trizen\n\n# Generate squarefree k-almost prime numbers in range [a,b]. (not in sorted order)\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n\nuse 5.036;\nuse ntheory 0.074 qw(:all);\n\nsub squarefree_almost_primes ($A, $B, $k, $callback) {\n\n    $A = vecmax($A, pn_primorial($k));\n\n    sub ($m, $lo, $k) {\n\n        my $hi = rootint(divint($B, $m), $k);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        if ($k == 1) {\n\n            $lo = vecmax($lo, cdivint($A, $m));\n\n            if ($lo > $hi) {\n                return;\n            }\n\n            forprimes {\n                $callback->(mulint($m, $_));\n            } $lo, $hi;\n\n            return;\n        }\n\n        foreach my $p (@{primes($lo, $hi)}) {\n            __SUB__->(mulint($m, $p), $p+1, $k-1);\n        }\n    }->(1, 2, $k);\n}\n\n# Generate squarefree 5-almost primes in the range [3000, 10000]\n\nmy $k    = 5;\nmy $from = 3000;\nmy $upto = 10000;\n\nmy @arr; squarefree_almost_primes($from, $upto, $k, sub ($n) { push @arr, $n });\n\nmy @test = grep { is_almost_prime($k, $_) && is_square_free($_) } $from..$upto;   # just for testing\njoin(' ', sort { $a <=> $b } @arr) eq join(' ', @test) or die \"Error: not equal!\";\n\nsay join(', ', @arr);\n"
  },
  {
    "path": "Math/squarefree_almost_primes_in_range_from_factor_list.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 17 March 2023\n# https://github.com/trizen\n\n# Generate all the squarefree k-almost primes in a given range [A, B], using a given list of prime factors.\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\n\nsub squarefree_almost_primes_in_range ($A, $B, $k, $factors) {\n\n    $A = vecmax($A, pn_primorial($k));\n\n    my $factors_end = $#{$factors};\n\n    if ($k == 0) {\n        return (($A > 1) ? () : 1);\n    }\n\n    my @list;\n\n    sub ($m, $k, $i = 0) {\n\n        my $lo = $factors->[$i];\n        my $hi = rootint(divint($B, $m), $k);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        if ($k == 1) {\n\n            $lo = vecmax($lo, cdivint($A, $m));\n\n            if ($lo > $hi) {\n                return;\n            }\n\n            foreach my $j ($i .. $factors_end) {\n                my $q = $factors->[$j];\n                last if ($q > $hi);\n                next if ($q < $lo);\n                push(@list, mulint($m, $q));\n            }\n\n            return;\n        }\n\n        foreach my $j ($i .. $factors_end - 1) {\n            my $q = $factors->[$j];\n            last if ($q > $hi);\n            next if ($q < $lo);\n            __SUB__->(mulint($m, $q), $k - 1, $j + 1);\n        }\n      }\n      ->(1, $k);\n\n    sort { $a <=> $b } @list;\n}\n\nmy $from    = 1;\nmy $upto    = 1e6;\nmy @factors = @{primes(17)};    # prime list\n\nforeach my $k (0 .. scalar(@factors)) {\n    my @divisors = squarefree_almost_primes_in_range($from, $upto, $k, \\@factors);\n    printf(\"%2d-squarefree almost primes in range [%s, %s]: [%s]\\n\", $k, $from, $upto, join(', ', @divisors));\n}\n\n__END__\n 0-squarefree almost primes in range [1, 1000000]: [1]\n 1-squarefree almost primes in range [1, 1000000]: [2, 3, 5, 7, 11, 13, 17]\n 2-squarefree almost primes in range [1, 1000000]: [6, 10, 14, 15, 21, 22, 26, 33, 34, 35, 39, 51, 55, 65, 77, 85, 91, 119, 143, 187, 221]\n 3-squarefree almost primes in range [1, 1000000]: [30, 42, 66, 70, 78, 102, 105, 110, 130, 154, 165, 170, 182, 195, 231, 238, 255, 273, 286, 357, 374, 385, 429, 442, 455, 561, 595, 663, 715, 935, 1001, 1105, 1309, 1547, 2431]\n 4-squarefree almost primes in range [1, 1000000]: [210, 330, 390, 462, 510, 546, 714, 770, 858, 910, 1122, 1155, 1190, 1326, 1365, 1430, 1785, 1870, 2002, 2145, 2210, 2618, 2805, 3003, 3094, 3315, 3927, 4641, 4862, 5005, 6545, 7293, 7735, 12155, 17017]\n 5-squarefree almost primes in range [1, 1000000]: [2310, 2730, 3570, 4290, 5610, 6006, 6630, 7854, 9282, 10010, 13090, 14586, 15015, 15470, 19635, 23205, 24310, 34034, 36465, 51051, 85085]\n 6-squarefree almost primes in range [1, 1000000]: [30030, 39270, 46410, 72930, 102102, 170170, 255255]\n 7-squarefree almost primes in range [1, 1000000]: [510510]\n"
  },
  {
    "path": "Math/squarefree_almost_primes_in_range_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 10 March 2021\n# Edit: 04 April 2024\n# https://github.com/trizen\n\n# Generate all the squarefree k-almost prime numbers in range [A,B].\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n\nuse 5.036;\nuse ntheory qw(:all);\nuse Math::GMPz;\n\nsub squarefree_almost_primes ($A, $B, $k) {\n\n    $A = vecmax($A, pn_primorial($k));\n    $A = Math::GMPz->new(\"$A\");\n    $B = Math::GMPz->new(\"$B\");\n\n    my $u = Math::GMPz::Rmpz_init();\n\n    my @values = sub ($m, $lo, $k) {\n\n        Math::GMPz::Rmpz_tdiv_q($u, $B, $m);\n        Math::GMPz::Rmpz_root($u, $u, $k);\n\n        my $hi = Math::GMPz::Rmpz_get_ui($u);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        my @lst;\n\n        if ($k == 1) {\n\n            Math::GMPz::Rmpz_cdiv_q($u, $A, $m);\n\n            if (Math::GMPz::Rmpz_fits_ulong_p($u)) {\n                $lo = vecmax($lo, Math::GMPz::Rmpz_get_ui($u));\n            }\n            elsif (Math::GMPz::Rmpz_cmp_ui($u, $lo) > 0) {\n                if (Math::GMPz::Rmpz_cmp_ui($u, $hi) > 0) {\n                    return;\n                }\n                $lo = Math::GMPz::Rmpz_get_ui($u);\n            }\n\n            if ($lo > $hi) {\n                return;\n            }\n\n            foreach my $p (@{primes($lo, $hi)}) {\n                my $v = Math::GMPz::Rmpz_init();\n                Math::GMPz::Rmpz_mul_ui($v, $m, $p);\n                push @lst, $v;\n            }\n\n            return @lst;\n        }\n\n        my $z = Math::GMPz::Rmpz_init();\n\n        foreach my $p (@{primes($lo, $hi)}) {\n            Math::GMPz::Rmpz_mul_ui($z, $m, $p);\n            push @lst, __SUB__->($z, $p + 1, $k - 1);\n        }\n\n        return @lst;\n      }\n      ->(Math::GMPz->new(1), 2, $k);\n\n    sort { Math::GMPz::Rmpz_cmp($a, $b) } @values;\n}\n\n# Generate squarefree 5-almost primes in the range [3000, 10000]\n\nmy $k    = 5;\nmy $from = 3000;\nmy $upto = 10000;\n\nmy @arr  = squarefree_almost_primes($from, $upto, $k);\nmy @test = grep { is_almost_prime($k, $_) && is_square_free($_) } $from .. $upto;    # just for testing\n\njoin(' ', @arr) eq join(' ', @test) or die \"Error: not equal!\";\n\nsay join(', ', @arr);\n"
  },
  {
    "path": "Math/squarefree_divisors.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 08 July 2018\n# https://github.com/trizen\n\n# Generate the squarefree divisors of a given number.\n\n# See also:\n#   https://oeis.org/A048250\n\nuse 5.036;\nuse ntheory qw(:all);\n\nsub squarefree_divisors($n) {\n\n    my @d = (1);\n    my @pp = map { $_->[0] } factor_exp($n);\n\n    foreach my $p (@pp) {\n        push @d, map { mulint($_, $p) } @d;\n    }\n\n    return sort { $a <=> $b } @d;\n}\n\nforeach my $n (1 .. 20) {\n    my @d = squarefree_divisors($n);\n    say \"squarefree divisors of $n: [@d]\";\n}\n\n__END__\nsquarefree divisors of 1: [1]\nsquarefree divisors of 2: [1 2]\nsquarefree divisors of 3: [1 3]\nsquarefree divisors of 4: [1 2]\nsquarefree divisors of 5: [1 5]\nsquarefree divisors of 6: [1 2 3 6]\nsquarefree divisors of 7: [1 7]\nsquarefree divisors of 8: [1 2]\nsquarefree divisors of 9: [1 3]\nsquarefree divisors of 10: [1 2 5 10]\nsquarefree divisors of 11: [1 11]\nsquarefree divisors of 12: [1 2 3 6]\nsquarefree divisors of 13: [1 13]\nsquarefree divisors of 14: [1 2 7 14]\nsquarefree divisors of 15: [1 3 5 15]\nsquarefree divisors of 16: [1 2]\nsquarefree divisors of 17: [1 17]\nsquarefree divisors of 18: [1 2 3 6]\nsquarefree divisors of 19: [1 19]\nsquarefree divisors of 20: [1 2 5 10]\n"
  },
  {
    "path": "Math/squarefree_fermat_overpseudoprimes_in_range.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 28 August 2022\n# Edit: 04 September 2022\n# https://github.com/trizen\n\n# Generate all the squarefree Fermat overpseudoprimes to a given base with n prime factors in a given range [a,b]. (not in sorted order)\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\nuse Memoize qw(memoize);\n\nmemoize('inverse_znorder_primes');\n\nsub inverse_znorder_primes ($base, $lambda) {\n    my %seen;\n    grep { !$seen{$_}++ } factor(subint(powint($base, $lambda), 1));\n}\n\nsub iterate_over_primes ($x, $y, $base, $lambda, $callback) {\n\n    if ($lambda > 1 and $lambda <= 135) {\n        foreach my $p (inverse_znorder_primes($base, $lambda)) {\n\n            next if $p < $x;\n            last if $p > $y;\n\n            #znorder($base, $p) == $lambda or next;\n\n            $callback->($p);\n        }\n        return;\n    }\n\n    if ($lambda > 1) {\n        for (my $w = $lambda * cdivint($x - 1, $lambda) ; $w <= $y ; $w += $lambda) {\n            if (is_prime($w + 1) and powmod($base, $lambda, $w + 1) == 1) {\n                $callback->($w + 1);\n            }\n        }\n        return;\n    }\n\n    for (my $p = next_prime($x - 1) ; $p <= $y ; $p = next_prime($p)) {\n        $callback->($p);\n    }\n}\n\nsub squarefree_fermat_overpseudoprimes_in_range ($A, $B, $k, $base, $callback) {\n\n    $A = vecmax($A, pn_primorial($k));\n\n    my $F;\n    $F = sub ($m, $lambda, $lo, $k) {\n\n        my $hi = rootint(divint($B, $m), $k);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        if ($k == 1) {\n\n            $lo = vecmax($lo, cdivint($A, $m));\n\n            if ($lo > $hi) {\n                return;\n            }\n\n            iterate_over_primes(\n                $lo, $hi, $base, $lambda,\n                sub ($p) {\n                    if (powmod($base, $lambda, $p) == 1) {\n                        if (($m * $p - 1) % $lambda == 0 and znorder($base, $p) == $lambda) {\n                            $callback->($m * $p);\n                        }\n                    }\n                }\n            );\n\n            return;\n        }\n\n        iterate_over_primes(\n            $lo, $hi, $base, $lambda,\n            sub ($p) {\n                if ($base % $p != 0) {\n                    my $z = znorder($base, $p);\n                    if (($z == $lambda or $lambda == 1) and gcd($z, $m) == 1) {\n                        $F->($m * $p, $z, $p + 1, $k - 1);\n                    }\n                }\n            }\n        );\n    };\n\n    $F->(1, 1, 2, $k);\n    undef $F;\n}\n\n# Generate all the squarefree Fermat overpseudoprimes to base 2 with 3 prime factors in the range [13421773, 412346200100]\n\nmy $k    = 3;\nmy $base = 2;\nmy $from = 13421773;\nmy $upto = 412346200100;\n\nmy @arr; squarefree_fermat_overpseudoprimes_in_range($from, $upto, $k, $base, sub ($n) { push @arr, $n });\n\nsay join(', ', sort { $a <=> $b } @arr);\n\n__END__\n13421773, 464955857, 536870911, 1220114377, 1541955409, 2454285751, 3435973837, 5256967999, 5726579371, 7030714813, 8493511669, 8538455017, 8788016089, 10545166433, 13893138041, 17112890881, 18723407341, 19089110641, 21335883193, 23652189937, 37408911097, 43215089153, 47978858771, 50032571509, 50807757529, 54975581389, 59850086533, 65700513721, 68713275457, 78889735961, 85139035489, 90171022049, 99737787437, 105207688757, 125402926477, 149583518641, 161624505241, 168003672409, 175303004581, 206005507811, 219687786701, 252749217641, 262106396551, 265866960649, 276676965109, 280792563977, 294207272761, 306566231341, 355774589609, 381491063773\n"
  },
  {
    "path": "Math/squarefree_fermat_pseudoprimes_in_range.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 28 August 2022\n# https://github.com/trizen\n\n# Generate all the squarefree Fermat pseudoprimes to a given base with n prime factors in a given range [A,B]. (not in sorted order)\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\n# PARI/GP program (in range) (simple):\n#   squarefree_fermat(A, B, k, base=2) = A=max(A, vecprod(primes(k))); (f(m, l, lo, k) = my(list=List()); my(hi=sqrtnint(B\\m, k)); if(lo > hi, return(list)); if(k==1, forprime(p=max(lo, ceil(A/m)), hi, if(base%p != 0, my(t=m*p); if((t-1)%l == 0 && (t-1)%znorder(Mod(base, p)) == 0, listput(list, t)))), forprime(p=lo, hi, if (base%p != 0, my(z=znorder(Mod(base, p))); if(gcd(m, z) == 1, list=concat(list, f(m*p, lcm(l,z), p+1, k-1)))))); list); vecsort(Vec(f(1, 1, 2, k)));\n\n# PARI/GP program (in range) (faster):\n#   squarefree_fermat(A, B, k, base=2) = A=max(A, vecprod(primes(k))); (f(m, l, lo, k) = my(list=List()); my(hi=sqrtnint(B\\m, k)); if(lo > hi, return(list)); if(k==1, lo=max(lo, ceil(A/m)); my(t=lift(1/Mod(m,l))); while(t < lo, t += l); forstep(p=t, hi, l, if(isprime(p), my(n=m*p); if((n-1)%znorder(Mod(base, p)) == 0, listput(list, n)))), forprime(p=lo, hi, if (base%p != 0, my(z=znorder(Mod(base, p))); if(gcd(m, z) == 1, list=concat(list, f(m*p, lcm(l,z), p+1, k-1)))))); list); vecsort(Vec(f(1, 1, 2, k)));\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\n\nsub squarefree_fermat_pseudoprimes_in_range ($A, $B, $k, $base) {\n\n    $A = vecmax($A, pn_primorial($k));\n\n    my @list;\n\n    sub ($m, $L, $lo, $k) {\n\n        my $hi = rootint(divint($B, $m), $k);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        if ($k == 1) {\n\n            $lo = vecmax($lo, cdivint($A, $m));\n            $lo > $hi && return;\n\n            my $t = invmod($m, $L);\n            $t > $hi && return;\n            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);\n\n            for (my $p = $t ; $p <= $hi ; $p += $L) {\n                if (is_prime($p) and $base % $p != 0) {\n                    if (($m * $p - 1) % znorder($base, $p) == 0) {\n                        push(@list, $m * $p);\n                    }\n                }\n            }\n\n            return;\n        }\n\n        foreach my $p (@{primes($lo, $hi)}) {\n\n            $base % $p == 0 and next;\n            my $z = znorder($base, $p);\n            gcd($m, $z) == 1 or next;\n\n            __SUB__->($m * $p, lcm($L, $z), $p + 1, $k - 1);\n        }\n      }\n      ->(1, 1, 2, $k);\n\n    return sort { $a <=> $b } @list;\n}\n\n# Generate all the squarefree Fermat pseudoprimes to base 2 with 5 prime factors in the range [100, 10^8]\n\nmy $k    = 5;\nmy $base = 2;\nmy $from = 100;\nmy $upto = 1e8;\n\nmy @arr = squarefree_fermat_pseudoprimes_in_range($from, $upto, $k, $base);\n\nsay join(', ', sort { $a <=> $b } @arr);\n\n# Run some tests\n\nif (1) {    # true to run some tests\n    foreach my $k (2 .. 6) {\n\n        my $lo           = pn_primorial($k);\n        my $hi           = mulint($lo, 1000);\n        my @omega_primes = grep { is_square_free($_) } @{omega_primes($k, $lo, $hi)};\n\n        foreach my $base (2 .. 100) {\n            my @this = grep { is_pseudoprime($_, $base) } @omega_primes;\n            my @that = squarefree_fermat_pseudoprimes_in_range($lo, $hi, $k, $base);\n            join(' ', @this) eq join(' ', @that)\n              or die \"Error for k = $k and base = $base with hi = $hi\\n(@this) != (@that)\";\n        }\n    }\n}\n\n__END__\n825265, 1050985, 1275681, 2113665, 2503501, 2615977, 2882265, 3370641, 3755521, 4670029, 4698001, 4895065, 5034601, 6242685, 6973057, 7428421, 8322945, 9223401, 9224391, 9890881, 10877581, 12067705, 12945745, 13757653, 13823601, 13992265, 16778881, 17698241, 18007345, 18162001, 18779761, 19092921, 22203181, 22269745, 23386441, 25266745, 25831585, 26553241, 27218269, 27336673, 27736345, 28175001, 28787185, 31146661, 32368609, 32428045, 32756581, 34111441, 34386121, 35428141, 36121345, 36168265, 36507801, 37167361, 37695505, 37938901, 38790753, 40280065, 40886241, 41298985, 41341321, 41424801, 41471521, 42689305, 43136821, 46282405, 47006785, 49084321, 49430305, 51396865, 52018341, 52452905, 53661945, 54177949, 54215161, 54651961, 55035001, 55329985, 58708761, 59586241, 60761701, 61679905, 63337393, 63560685, 64567405, 64685545, 67371265, 67994641, 68830021, 69331969, 71804161, 72135505, 72192021, 72348409, 73346365, 73988641, 74165065, 75151441, 76595761, 77442905, 78397705, 80787421, 83058481, 84028407, 84234745, 85875361, 86968981, 88407361, 88466521, 88689601, 89816545, 89915365, 92027001, 92343745, 92974921, 93614521, 93839201, 93869665, 96259681, 96386865, 96653985, 98124481, 98756281, 99551881\n"
  },
  {
    "path": "Math/squarefree_fermat_pseudoprimes_in_range_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 25 February 2023\n# https://github.com/trizen\n\n# Generate all the squarefree Fermat pseudoprimes to a given base with n prime factors in a given range [A,B]. (not in sorted order)\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\n# PARI/GP program (in range):\n#   squarefree_fermat(A, B, k, base=2) = A=max(A, vecprod(primes(k))); (f(m, l, lo, k) = my(list=List()); my(hi=sqrtnint(B\\m, k)); if(lo > hi, return(list)); if(k==1, forprime(p=max(lo, ceil(A/m)), hi, if(base%p != 0, my(t=m*p); if((t-1)%l == 0 && (t-1)%znorder(Mod(base, p)) == 0, listput(list, t)))), forprime(p=lo, hi, if (base%p != 0, my(z=znorder(Mod(base, p))); if(gcd(m, z) == 1, list=concat(list, f(m*p, lcm(l,z), p+1, k-1)))))); list); vecsort(Vec(f(1, 1, 2, k)));\n\n# PARI/GP program (in range) (faster):\n#   squarefree_fermat(A, B, k, base=2) = A=max(A, vecprod(primes(k))); (f(m, l, lo, k) = my(list=List()); my(hi=sqrtnint(B\\m, k)); if(lo > hi, return(list)); if(k==1, lo=max(lo, ceil(A/m)); my(t=lift(1/Mod(m,l))); while(t < lo, t += l); forstep(p=t, hi, l, if(isprime(p), my(n=m*p); if((n-1)%znorder(Mod(base, p)) == 0, listput(list, n)))), forprime(p=lo, hi, if (base%p != 0, my(z=znorder(Mod(base, p))); if(gcd(m, z) == 1, list=concat(list, f(m*p, lcm(l,z), p+1, k-1)))))); list); vecsort(Vec(f(1, 1, 2, k)));\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory 0.74 qw(:all);\n\nsub squarefree_fermat_pseudoprimes_in_range ($A, $B, $k, $base) {\n\n    $A = vecmax($A, pn_primorial($k));\n\n    $A = Math::GMPz->new(\"$A\");\n    $B = Math::GMPz->new(\"$B\");\n\n    my $u = Math::GMPz::Rmpz_init();\n    my $v = Math::GMPz::Rmpz_init();\n\n    my @list;\n\n    sub ($m, $L, $lo, $k) {\n\n        Math::GMPz::Rmpz_tdiv_q($u, $B, $m);\n        Math::GMPz::Rmpz_root($u, $u, $k);\n\n        my $hi = Math::GMPz::Rmpz_get_ui($u);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        if ($k == 1) {\n\n            Math::GMPz::Rmpz_cdiv_q($u, $A, $m);\n\n            if (Math::GMPz::Rmpz_fits_ulong_p($u)) {\n                $lo = vecmax($lo, Math::GMPz::Rmpz_get_ui($u));\n            }\n            elsif (Math::GMPz::Rmpz_cmp_ui($u, $lo) > 0) {\n                if (Math::GMPz::Rmpz_cmp_ui($u, $hi) > 0) {\n                    return;\n                }\n                $lo = Math::GMPz::Rmpz_get_ui($u);\n            }\n\n            if ($lo > $hi) {\n                return;\n            }\n\n            Math::GMPz::Rmpz_invert($v, $m, $L);\n\n            if (Math::GMPz::Rmpz_cmp_ui($v, $hi) > 0) {\n                return;\n            }\n\n            if (Math::GMPz::Rmpz_fits_ulong_p($L)) {\n                $L = Math::GMPz::Rmpz_get_ui($L);\n            }\n\n            my $t = Math::GMPz::Rmpz_get_ui($v);\n            $t > $hi && return;\n            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);\n\n            for (my $p = $t ; $p <= $hi ; $p += $L) {\n                if (is_prime($p) and $base % $p != 0) {\n                    Math::GMPz::Rmpz_mul_ui($v, $m, $p);\n                    Math::GMPz::Rmpz_sub_ui($u, $v, 1);\n                    if (Math::GMPz::Rmpz_divisible_ui_p($u, znorder($base, $p))) {\n                        push(@list, Math::GMPz::Rmpz_init_set($v));\n                    }\n                }\n            }\n\n            return;\n        }\n\n        my $t   = Math::GMPz::Rmpz_init();\n        my $lcm = Math::GMPz::Rmpz_init();\n\n        foreach my $p (@{primes($lo, $hi)}) {\n\n            $base % $p == 0 and next;\n            my $z = znorder($base, $p);\n            Math::GMPz::Rmpz_gcd_ui($Math::GMPz::NULL, $m, $z) == 1 or next;\n            Math::GMPz::Rmpz_lcm_ui($lcm, $L, $z);\n            Math::GMPz::Rmpz_mul_ui($t, $m, $p);\n\n            __SUB__->($t, $lcm, $p + 1, $k - 1);\n        }\n      }\n      ->(Math::GMPz->new(1), Math::GMPz->new(1), 2, $k);\n\n    return sort { $a <=> $b } @list;\n}\n\n# Generate all the squarefree Fermat pseudoprimes to base 2 with 5 prime factors in the range [100, 10^8]\n\nmy $k    = 5;\nmy $base = 3;\nmy $from = 100;\nmy $upto = 1e8;\n\nmy @arr = squarefree_fermat_pseudoprimes_in_range($from, $upto, $k, $base);\nsay join(', ', @arr);\n\n__END__\n825265, 1050985, 1275681, 2113665, 2503501, 2615977, 2882265, 3370641, 3755521, 4670029, 4698001, 4895065, 5034601, 6242685, 6973057, 7428421, 8322945, 9223401, 9224391, 9890881, 10877581, 12067705, 12945745, 13757653, 13823601, 13992265, 16778881, 17698241, 18007345, 18162001, 18779761, 19092921, 22203181, 22269745, 23386441, 25266745, 25831585, 26553241, 27218269, 27336673, 27736345, 28175001, 28787185, 31146661, 32368609, 32428045, 32756581, 34111441, 34386121, 35428141, 36121345, 36168265, 36507801, 37167361, 37695505, 37938901, 38790753, 40280065, 40886241, 41298985, 41341321, 41424801, 41471521, 42689305, 43136821, 46282405, 47006785, 49084321, 49430305, 51396865, 52018341, 52452905, 53661945, 54177949, 54215161, 54651961, 55035001, 55329985, 58708761, 59586241, 60761701, 61679905, 63337393, 63560685, 64567405, 64685545, 67371265, 67994641, 68830021, 69331969, 71804161, 72135505, 72192021, 72348409, 73346365, 73988641, 74165065, 75151441, 76595761, 77442905, 78397705, 80787421, 83058481, 84028407, 84234745, 85875361, 86968981, 88407361, 88466521, 88689601, 89816545, 89915365, 92027001, 92343745, 92974921, 93614521, 93839201, 93869665, 96259681, 96386865, 96653985, 98124481, 98756281, 99551881\n"
  },
  {
    "path": "Math/squarefree_lucas_U_pseudoprimes_in_range.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 06 September 2022\n# https://github.com/trizen\n\n# Generate all the squarefree Lucas pseudoprimes to the U_n(P,Q) sequence with n prime factors in a given range [a,b]. (not in sorted order)\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://en.wikipedia.org/wiki/Lucas_sequence\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\n\nsub lucas_znorder ($P, $Q, $D, $n) {\n\n    foreach my $d (divisors($n - kronecker($D, $n))) {\n        my ($u, $v) = lucas_sequence($n, $P, $Q, $d);\n        if ($u == 0) {\n            return $d;\n        }\n    }\n\n    return undef;\n}\n\nsub squarefree_lucas_U_pseudoprimes_in_range ($A, $B, $k, $P, $Q) {\n\n    $A = vecmax($A, pn_primorial($k));\n    my $D = $P * $P - 4 * $Q;\n\n    my @list;\n\n    sub ($m, $L, $lo, $k) {\n\n        my $hi = rootint(divint($B, $m), $k);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        if ($k == 1) {\n\n            $lo = vecmax($lo, cdivint($A, $m));\n            $lo > $hi && return;\n\n            foreach my $j (1, -1) {\n\n                my $t = mulmod(invmod($m, $L), $j, $L);\n                $t > $hi && next;\n                $t += $L * cdivint($lo - $t, $L) if ($t < $lo);\n\n                for (my $p = $t ; $p <= $hi ; $p += $L) {\n                    if (is_prime($p)) {\n                        my $n = $m * $p;\n                        my $w = $n - kronecker($D, $n);\n                        if ($w % $L == 0 and $w % lucas_znorder($P, $Q, $D, $p) == 0) {\n                            push(@list, $n);\n                        }\n                    }\n                }\n            }\n\n            return;\n        }\n\n        foreach my $p (@{primes($lo, $hi)}) {\n\n            $D % $p == 0 and next;\n\n            my $z = lucas_znorder($P, $Q, $D, $p) // next;\n            gcd($m, $z) == 1 or next;\n\n            __SUB__->($m * $p, lcm($L, $z), $p + 1, $k - 1);\n        }\n      }\n      ->(1, 1, 2, $k);\n\n    return sort { $a <=> $b } @list;\n}\n\n# Generate all the squarefree Fibonacci pseudoprimes in the range [1, 64681]\n\nmy $from = 1;\nmy $upto = 64681;\nmy ($P, $Q) = (1, -1);\n\nmy @arr;\nforeach my $k (2 .. 100) {\n    last if pn_primorial($k) > $upto;\n    push @arr, squarefree_lucas_U_pseudoprimes_in_range($from, $upto, $k, $P, $Q);\n}\n\nsay join(', ', sort { $a <=> $b } @arr);\n\n__END__\n323, 377, 1891, 3827, 4181, 5777, 6601, 6721, 8149, 10877, 11663, 13201, 13981, 15251, 17119, 17711, 18407, 19043, 23407, 25877, 27323, 30889, 34561, 34943, 35207, 39203, 40501, 50183, 51841, 51983, 52701, 53663, 60377, 64079, 64681\n"
  },
  {
    "path": "Math/squarefree_strong_fermat_pseudoprimes_in_range.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 24 September 2022\n# https://github.com/trizen\n\n# Generate all the squarefree strong Fermat pseudoprimes to a given base with n prime factors in a given range [A,B]. (not in sorted order)\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\n\nsub squarefree_strong_fermat_pseudoprimes_in_range ($A, $B, $k, $base) {\n\n    $A = vecmax($A, pn_primorial($k));\n\n    if ($A > $B) {\n        return;\n    }\n\n    my @list;\n\n    my $generator = sub ($m, $L, $lo, $k, $k_exp, $congr) {\n\n        my $hi = rootint(divint($B, $m), $k);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        if ($k == 1) {\n\n            $lo = vecmax($lo, cdivint($A, $m));\n            $lo > $hi && return;\n\n            my $t = invmod($m, $L);\n            $t > $hi && return;\n            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);\n\n            for (my $p = $t ; $p <= $hi ; $p += $L) {\n\n                is_prime($p) || next;\n                $base % $p == 0 and next;\n\n                my $val = valuation($p - 1, 2);\n                if ($val > $k_exp and powmod($base, ($p - 1) >> ($val - $k_exp), $p) == ($congr % $p)) {\n                    my $n = $m * $p;\n                    if (($n - 1) % znorder($base, $p) == 0) {\n                        push @list, $n;\n                    }\n                }\n            }\n\n            return;\n        }\n\n        foreach my $p (@{primes($lo, $hi)}) {\n\n            $base % $p == 0 and next;\n\n            my $val = valuation($p - 1, 2);\n            $val > $k_exp                                                   or next;\n            powmod($base, ($p - 1) >> ($val - $k_exp), $p) == ($congr % $p) or next;\n\n            my $z = znorder($base, $p);\n            if (gcd($m, $z) == 1) {\n                __SUB__->($m * $p, lcm($L, $z), $p + 1, $k - 1, $k_exp, $congr);\n            }\n        }\n    };\n\n    # Case where 2^d == 1 (mod p), where d is the odd part of p-1.\n    $generator->(1, 1, 2, $k, 0, 1);\n\n    # Cases where 2^(d * 2^v) == -1 (mod p), for some v >= 0.\n    foreach my $v (0 .. logint($B, 2)) {\n        $generator->(1, 1, 2, $k, $v, -1);\n    }\n\n    return sort { $a <=> $b } @list;\n}\n\n# Generate all the squarefree strong Fermat pseudoprimes to base 2 with 3 prime factors in the range [1, 10^8]\n\nmy $k    = 3;\nmy $base = 2;\nmy $from = 1;\nmy $upto = 1e8;\n\nmy @arr = squarefree_strong_fermat_pseudoprimes_in_range($from, $upto, $k, $base);\nsay join(', ', @arr);\n\n__END__\n15841, 29341, 52633, 74665, 252601, 314821, 476971, 635401, 1004653, 1023121, 1907851, 1909001, 2419385, 2953711, 3581761, 4335241, 4682833, 5049001, 5444489, 5599765, 5681809, 9069229, 13421773, 15247621, 15510041, 15603391, 17509501, 26254801, 26758057, 27966709, 29111881, 35703361, 36765901, 37769887, 38342071, 44963029, 47349373, 47759041, 53399449, 53711113, 54468001, 60155201, 61377109, 61755751, 66977281, 68154001, 70030501, 71572957, 74329399, 82273201, 91659283, 99036001\n"
  },
  {
    "path": "Math/squarefree_strong_fermat_pseudoprimes_in_range_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 25 February 2023\n# https://github.com/trizen\n\n# Generate all the squarefree strong Fermat pseudoprimes to a given base with n prime factors in a given range [A,B]. (not in sorted order)\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory 0.74 qw(:all);\n\nsub squarefree_strong_fermat_pseudoprimes_in_range ($A, $B, $k, $base) {\n\n    $A = vecmax($A, pn_primorial($k));\n\n    $A = Math::GMPz->new(\"$A\");\n    $B = Math::GMPz->new(\"$B\");\n\n    my $u = Math::GMPz::Rmpz_init();\n    my $v = Math::GMPz::Rmpz_init();\n\n    my @list;\n\n    my $generator = sub ($m, $L, $lo, $k, $k_exp, $congr) {\n\n        Math::GMPz::Rmpz_tdiv_q($u, $B, $m);\n        Math::GMPz::Rmpz_root($u, $u, $k);\n\n        my $hi = Math::GMPz::Rmpz_get_ui($u);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        if ($k == 1) {\n\n            Math::GMPz::Rmpz_cdiv_q($u, $A, $m);\n\n            if (Math::GMPz::Rmpz_fits_ulong_p($u)) {\n                $lo = vecmax($lo, Math::GMPz::Rmpz_get_ui($u));\n            }\n            elsif (Math::GMPz::Rmpz_cmp_ui($u, $lo) > 0) {\n                if (Math::GMPz::Rmpz_cmp_ui($u, $hi) > 0) {\n                    return;\n                }\n                $lo = Math::GMPz::Rmpz_get_ui($u);\n            }\n\n            if ($lo > $hi) {\n                return;\n            }\n\n            Math::GMPz::Rmpz_invert($v, $m, $L);\n\n            if (Math::GMPz::Rmpz_cmp_ui($v, $hi) > 0) {\n                return;\n            }\n\n            if (Math::GMPz::Rmpz_fits_ulong_p($L)) {\n                $L = Math::GMPz::Rmpz_get_ui($L);\n            }\n\n            my $t = Math::GMPz::Rmpz_get_ui($v);\n            $t > $hi && return;\n            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);\n\n            for (my $p = $t ; $p <= $hi ; $p += $L) {\n\n                is_prime($p) || next;\n                $base % $p == 0 and next;\n\n                my $val = valuation($p - 1, 2);\n                if ($val > $k_exp and powmod($base, ($p - 1) >> ($val - $k_exp), $p) == ($congr % $p)) {\n                    Math::GMPz::Rmpz_mul_ui($v, $m, $p);\n                    Math::GMPz::Rmpz_sub_ui($u, $v, 1);\n                    if (Math::GMPz::Rmpz_divisible_ui_p($u, znorder($base, $p))) {\n                        push(@list, Math::GMPz::Rmpz_init_set($v));\n                    }\n                }\n            }\n\n            return;\n        }\n\n        my $t   = Math::GMPz::Rmpz_init();\n        my $lcm = Math::GMPz::Rmpz_init();\n\n        foreach my $p (@{primes($lo, $hi)}) {\n\n            $base % $p == 0 and next;\n\n            my $val = valuation($p - 1, 2);\n            $val > $k_exp                                                   or next;\n            powmod($base, ($p - 1) >> ($val - $k_exp), $p) == ($congr % $p) or next;\n\n            my $z = znorder($base, $p);\n            Math::GMPz::Rmpz_gcd_ui($Math::GMPz::NULL, $m, $z) == 1 or next;\n            Math::GMPz::Rmpz_lcm_ui($lcm, $L, $z);\n            Math::GMPz::Rmpz_mul_ui($t, $m, $p);\n\n            __SUB__->($t, $lcm, $p + 1, $k - 1, $k_exp, $congr);\n        }\n    };\n\n    # Case where 2^d == 1 (mod p), where d is the odd part of p-1.\n    $generator->(Math::GMPz->new(1), Math::GMPz->new(1), 2, $k, 0, 1);\n\n    # Cases where 2^(d * 2^v) == -1 (mod p), for some v >= 0.\n    foreach my $v (0 .. logint($B, 2)) {\n        $generator->(Math::GMPz->new(1), Math::GMPz->new(1), 2, $k, $v, -1);\n    }\n\n    return sort { $a <=> $b } @list;\n}\n\n# Generate all the squarefree strong Fermat pseudoprimes to base 2 with 3 prime factors in the range [1, 10^8]\n\nmy $k    = 3;\nmy $base = 2;\nmy $from = 1;\nmy $upto = 1e8;\n\nmy @arr = squarefree_strong_fermat_pseudoprimes_in_range($from, $upto, $k, $base);\nsay join(', ', @arr);\n\n__END__\n15841, 29341, 52633, 74665, 252601, 314821, 476971, 635401, 1004653, 1023121, 1907851, 1909001, 2419385, 2953711, 3581761, 4335241, 4682833, 5049001, 5444489, 5599765, 5681809, 9069229, 13421773, 15247621, 15510041, 15603391, 17509501, 26254801, 26758057, 27966709, 29111881, 35703361, 36765901, 37769887, 38342071, 44963029, 47349373, 47759041, 53399449, 53711113, 54468001, 60155201, 61377109, 61755751, 66977281, 68154001, 70030501, 71572957, 74329399, 82273201, 91659283, 99036001\n"
  },
  {
    "path": "Math/squarefree_strong_fermat_pseudoprimes_to_multiple_bases_in_range.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 09 March 2023\n# https://github.com/trizen\n\n# Generate all the squarefree k-omega strong Fermat pseudoprimes in range [A,B] to multiple given bases. (not in sorted order)\n\n# See also:\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\n\nsub squarefree_strong_fermat_pseudoprimes_in_range ($A, $B, $k, $bases) {\n\n    $A = vecmax($A, pn_primorial($k));\n    $A > $B and return;\n\n    my @bases     = @$bases;\n    my $bases_lcm = lcm(@bases);\n\n    my @list;\n\n    sub ($m, $L, $lo, $k) {\n\n        my $hi = rootint(divint($B, $m), $k);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        if ($k == 1) {\n\n            $lo = vecmax($lo, cdivint($A, $m));\n            $lo > $hi && return;\n\n            my $t = invmod($m, $L) // return;\n            $t > $hi && return;\n            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);\n\n            for (my $p = $t ; $p <= $hi ; $p += $L) {\n                if (is_prime($p) and $bases_lcm % $p != 0 and $m % $p != 0) {\n                    my $v = $m * $p;\n                    if (is_strong_pseudoprime($v, @bases)) {\n                        push(@list, $v);\n                    }\n                }\n            }\n\n            return;\n        }\n\n        foreach my $p (@{primes($lo, $hi)}) {\n\n            $bases_lcm % $p == 0 and next;\n\n            my $lcm = lcm(map { znorder($_, $p) } @bases);\n            gcd($m, $lcm) == 1 or next;\n\n            __SUB__->($m * $p, lcm($L, $lcm), $p + 1, $k - 1);\n        }\n      }\n      ->(1, 1, 2, $k);\n\n    return sort { $a <=> $b } @list;\n}\n\n# Generate all the strong Fermat pseudoprimes to base 2,3 in range [1, 54029741]\n\nmy $from  = 1;\nmy $upto  = 54029741;\nmy @bases = (2, 3);\n\nmy @arr;\nforeach my $k (2 .. 100) {\n    last if pn_primorial($k) > $upto;\n    push @arr, squarefree_strong_fermat_pseudoprimes_in_range($from, $upto, $k, \\@bases);\n}\n\nsay join(', ', sort { $a <=> $b } @arr);\n\n__END__\n1373653, 1530787, 1987021, 2284453, 3116107, 5173601, 6787327, 11541307, 13694761, 15978007, 16070429, 16879501, 25326001, 27509653, 27664033, 28527049, 54029741\n"
  },
  {
    "path": "Math/squarefree_strong_fermat_pseudoprimes_to_multiple_bases_in_range_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 23 December 2023\n# https://github.com/trizen\n\n# Generate all the squarefree k-omega strong Fermat pseudoprimes in range [A,B] to multiple given bases. (not in sorted order)\n\n# See also:\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory 0.74 qw(:all);\n\nsub k_squarefree_strong_fermat_pseudoprimes_in_range ($A, $B, $k, $bases) {\n\n    $A = vecmax($A, pn_primorial($k));\n\n    my @bases     = @$bases;\n    my $bases_lcm = lcm(@bases);\n\n    $A = Math::GMPz->new(\"$A\");\n    $B = Math::GMPz->new(\"$B\");\n\n    my $u = Math::GMPz::Rmpz_init();\n    my $v = Math::GMPz::Rmpz_init();\n\n    my @list;\n\n    my $generator = sub ($m, $L, $lo, $k) {\n\n        Math::GMPz::Rmpz_tdiv_q($u, $B, $m);\n        Math::GMPz::Rmpz_root($u, $u, $k);\n\n        my $hi = Math::GMPz::Rmpz_get_ui($u);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        if ($k == 1) {\n\n            Math::GMPz::Rmpz_cdiv_q($u, $A, $m);\n\n            if (Math::GMPz::Rmpz_fits_ulong_p($u)) {\n                $lo = vecmax($lo, Math::GMPz::Rmpz_get_ui($u));\n            }\n            elsif (Math::GMPz::Rmpz_cmp_ui($u, $lo) > 0) {\n                if (Math::GMPz::Rmpz_cmp_ui($u, $hi) > 0) {\n                    return;\n                }\n                $lo = Math::GMPz::Rmpz_get_ui($u);\n            }\n\n            if ($lo > $hi) {\n                return;\n            }\n\n            Math::GMPz::Rmpz_invert($v, $m, $L);\n\n            if (Math::GMPz::Rmpz_cmp_ui($v, $hi) > 0) {\n                return;\n            }\n\n            if (Math::GMPz::Rmpz_fits_ulong_p($L)) {\n                $L = Math::GMPz::Rmpz_get_ui($L);\n            }\n\n            my $t = Math::GMPz::Rmpz_get_ui($v);\n            $t > $hi && return;\n            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);\n\n            for (my $p = $t ; $p <= $hi ; $p += $L) {\n\n                is_prime($p) || next;\n                $bases_lcm % $p == 0 and next;\n\n                Math::GMPz::Rmpz_mul_ui($v, $m, $p);\n                Math::GMPz::Rmpz_sub_ui($u, $v, 1);\n                if (vecall { is_strong_pseudoprime($v, $_) } @bases) {\n                    push(@list, Math::GMPz::Rmpz_init_set($v));\n                }\n            }\n\n            return;\n        }\n\n        my $t   = Math::GMPz::Rmpz_init();\n        my $lcm = Math::GMPz::Rmpz_init();\n\n        foreach my $p (@{primes($lo, $hi)}) {\n\n            $bases_lcm % $p == 0 and next;\n\n            my $z = lcm(map { znorder($_, $p) } @bases);\n            Math::GMPz::Rmpz_gcd_ui($Math::GMPz::NULL, $m, $z) == 1 or next;\n            Math::GMPz::Rmpz_lcm_ui($lcm, $L, $z);\n            Math::GMPz::Rmpz_mul_ui($t, $m, $p);\n\n            __SUB__->($t, $lcm, $p + 1, $k - 1);\n        }\n      }\n      ->(Math::GMPz->new(1), Math::GMPz->new(1), 2, $k);\n\n    return sort { $a <=> $b } @list;\n}\n\nsub squarefree_strong_fermat_pseudoprimes_in_range ($from, $upto, $bases) {\n\n    my @arr;\n\n    for (my $k = 2 ; ; ++$k) {\n        last if pn_primorial($k) > $upto;\n        push @arr, k_squarefree_strong_fermat_pseudoprimes_in_range($from, $upto, $k, $bases);\n    }\n\n    return sort { $a <=> $b } @arr;\n}\n\nmy @bases = (17, 31);\n\nmy $lo = Math::GMPz->new(2);\nmy $hi = 2 * $lo;\n\nsay \":: Searching for the smallest strong pseudoprime to bases: (@bases)\";\n\nwhile (1) {\n\n    say \":: Sieving range: [$lo, $hi]\";\n    my @arr = squarefree_strong_fermat_pseudoprimes_in_range($lo, $hi, \\@bases);\n\n    if (@arr) {\n        say \"\\nFound: $arr[0]\";\n        say \"All terms: @arr\\n\" if (@arr > 1);\n        last;\n    }\n\n    $lo = $hi + 1;\n    $hi = 2 * $lo;\n}\n\n__END__\n:: Searching for the smallest strong pseudoprime to bases: (17 31)\n:: Sieving range: [2, 4]\n:: Sieving range: [5, 10]\n:: Sieving range: [11, 22]\n:: Sieving range: [23, 46]\n:: Sieving range: [47, 94]\n:: Sieving range: [95, 190]\n:: Sieving range: [191, 382]\n:: Sieving range: [383, 766]\n:: Sieving range: [767, 1534]\n:: Sieving range: [1535, 3070]\n:: Sieving range: [3071, 6142]\n:: Sieving range: [6143, 12286]\n:: Sieving range: [12287, 24574]\n:: Sieving range: [24575, 49150]\n:: Sieving range: [49151, 98302]\n:: Sieving range: [98303, 196606]\n:: Sieving range: [196607, 393214]\n\nFound: 197209\nAll terms: 197209 269011\n\nperl script.pl  0.19s user 0.01s system 98% cpu 0.205 total\n"
  },
  {
    "path": "Math/stern_brocot_encoding.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 10 February 2018\n# https://github.com/trizen\n\n# Encode a given fraction into an integer, using the Stern-Brocot tree.\n\n# The decoding function decodes a given integer back into a fraction.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Stern%E2%80%93Brocot_tree\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload abs);\n\nsub stern_brocot_encode ($r) {\n\n    my ($m, $n) = abs($r)->nude;\n\n    my $enc = '';\n\n    for (; ;) {\n        if ((($m <=> $n) || last) < 0) {\n            $enc .= '0';\n            $n -= $m;\n        }\n        else {\n            $enc .= '1';\n            $m -= $n;\n        }\n    }\n\n    return $enc;\n}\n\nsub stern_brocot_decode ($e) {\n\n    my ($a, $b, $c, $d) = (1, 0, 0, 1);\n\n    foreach my $bit (split(//, $e)) {\n        if ($bit) {\n            $a += $b;\n            $c += $d;\n        }\n        else {\n            $b += $a;\n            $d += $c;\n        }\n    }\n\n    ($c + $d) / ($a + $b);\n}\n\nsay stern_brocot_encode(5 / 7);      # 0110\nsay stern_brocot_encode(43 / 97);    # 001110111111111\nsay stern_brocot_encode(97 / 43);    # 110001000000000\n\nsay '';\n\nsay stern_brocot_decode(stern_brocot_encode(5 / 7));      # 5/7\nsay stern_brocot_decode(stern_brocot_encode(43 / 97));    # 43/97\nsay stern_brocot_decode(stern_brocot_encode(97 / 43));    # 97/43\n\nsay \"\\n=> Tests:\";\n\nforeach my $n (1 .. 10) {\n\n    my $f = Math::AnyNum::factorial($n);\n    say \"dec($n!) = \", stern_brocot_decode($f->as_bin);\n\n    die \"[0] error for dec($n!)\" if (Math::AnyNum->new(stern_brocot_encode(stern_brocot_decode($f->as_bin)), 2) != $f);\n\n    my $r1 = Math::AnyNum::fibonacci($n) / Math::AnyNum::lucas($n);\n    die \"[1] error for $r1\" if (stern_brocot_decode(stern_brocot_encode($r1)) != $r1);\n\n    my $r2 = Math::AnyNum::lucas($n) / $n**2;\n    die \"[2] error for $r2\" if (stern_brocot_decode(stern_brocot_encode($r2)) != $r2);\n}\n"
  },
  {
    "path": "Math/stern_brocot_sequence.pl",
    "content": "#!/usr/bin/perl\n\n# Coded by Trizen\n# Date: 14 May 2015\n# https://github.com/trizen\n\nuse 5.010;\nuse strict;\nuse warnings;\n\n# Inspired from: https://www.youtube.com/watch?v=DpwUVExX27E\n\n#\n## Create and return the sequence as an array\n#\nsub stern_brocot {\n    my ($n) = @_;\n\n    my @fib = (1, 1);\n    foreach my $i (1 .. $n) {\n        push @fib, $fib[$i] + $fib[$i - 1], $fib[$i];\n    }\n    return @fib;\n}\n\nsay join(\" \", stern_brocot(15));\n\n#\n## Print the sequence as it is generated\n#\nsub stern_brocot_realtime(&$) {\n    my ($callback, $n) = @_;\n\n    my @fib = (1, 1);\n    foreach my $i (1 .. $n) {\n        push @fib, $fib[0] + $fib[1], $fib[1];\n        $callback->($fib[0]);\n        shift @fib;\n    }\n    $callback->($_) for @fib;\n}\n\n{\n    local $| = 1;\n    my $i = 0;\n    stern_brocot_realtime {\n        my ($n) = @_;\n        print \"$n \";\n    } 15;\n}\nprint \"\\n\";\n"
  },
  {
    "path": "Math/strong_fermat_pseudoprimes_in_range.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 24 September 2022\n# https://github.com/trizen\n\n# Generate all the k-omega strong Fermat pseudoprimes in range [A,B]. (not in sorted order)\n\n# Definition:\n#   k-omega primes are numbers n such that omega(n) = k.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://en.wikipedia.org/wiki/Prime_omega_function\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\n=for comment\n\n# PARI/GP program (slow):\n\nstrong_fermat_psp(A, B, k, base) = A=max(A, vecprod(primes(k))); (f(m, l, p, j, k_exp, congr) = my(list=List()); forprime(q=p, sqrtnint(B\\m, j), if(base%q != 0, my(tv=valuation(q-1, 2)); if(tv > k_exp && Mod(base, q)^(((q-1)>>tv)<<k_exp) == congr, my(v=m*q, t=q, r=nextprime(q+1)); while(v <= B, my(L=lcm(l, znorder(Mod(base, t)))); if(gcd(L, v) == 1, if(j==1, if(v>=A && if(k==1, !isprime(v), 1) && (v-1)%L == 0, listput(list, v)), if(v*r <= B, list=concat(list, f(v, L, r, j-1, k_exp, congr)))), break); v *= q; t *= q)))); list); my(r=f(1, 1, 2, k, 0, 1)); for(v=0, logint(B, 2), r=concat(r, f(1, 1, 2, k, v, -1))); vecsort(Vec(r));\n\n# PARI/GP program (fast):\n\nstrong_check(p, base, e, r) = my(tv=valuation(p-1, 2)); tv > e && Mod(base, p)^((p-1)>>(tv-e)) == r;\nstrong_fermat_psp(A, B, k, base) = A=max(A, vecprod(primes(k))); (f(m, l, lo, k, e, r) = my(list=List()); my(hi=sqrtnint(B\\m, k)); if(lo > hi, return(list)); if(k==1, forstep(p=lift(1/Mod(m, l)), hi, l, if(isprimepower(p) && gcd(m*base, p) == 1 && strong_check(p, base, e, r), my(n=m*p); if(n >= A && (n-1) % znorder(Mod(base, p)) == 0, listput(list, n)))), forprime(p=lo, hi, base%p == 0 && next; strong_check(p, base, e, r) || next; my(z=znorder(Mod(base, p))); gcd(m,z) == 1 || next; my(q=p, v=m*p); while(v <= B, list=concat(list, f(v, lcm(l, z), p+1, k-1, e, r)); q *= p; Mod(base, q)^z == 1 || break; v *= p))); list); my(res=f(1, 1, 2, k, 0, 1)); for(v=0, logint(B, 2), res=concat(res, f(1, 1, 2, k, v, -1))); vecsort(Set(res));\n\n=cut\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\n\nsub strong_fermat_pseudoprimes_in_range ($A, $B, $k, $base) {\n\n    $A = vecmax($A, pn_primorial($k));\n    $A > $B and return;\n\n    my %seen;\n    my @list;\n\n    my $generator = sub ($m, $L, $lo, $j, $k_exp, $congr) {\n\n        my $hi = rootint(divint($B, $m), $j);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        if ($j == 1) {\n\n            if ($L == 1) {    # optimization\n                foreach my $p (@{primes($lo, $hi)}) {\n\n                    $base % $p == 0 and next;\n\n                    my $val = valuation($p - 1, 2);\n                    $val > $k_exp                                                   or next;\n                    powmod($base, ($p - 1) >> ($val - $k_exp), $p) == ($congr % $p) or next;\n\n                    for (my $v = (($m == 1) ? ($p * $p) : ($m * $p)) ; $v <= $B ; $v *= $p) {\n                        $v >= $A                       or next;\n                        powmod($base, $v - 1, $v) == 1 or last;\n                        push(@list, $v) if !$seen{$v}++;\n                    }\n                }\n                return;\n            }\n\n            my $t = invmod($m, $L);\n            $t > $hi && return;\n            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);\n\n            for (my $p = $t ; $p <= $hi ; $p += $L) {\n                if (is_prime_power($p) and gcd($m, $p) == 1 and gcd($base, $p) == 1) {\n\n                    my $val = valuation($p - 1, 2);\n                    $val > $k_exp                                                   or next;\n                    powmod($base, ($p - 1) >> ($val - $k_exp), $p) == ($congr % $p) or next;\n\n                    my $v = $m * $p;\n                    $v >= $A                           or next;\n                    ($v - 1) % znorder($base, $p) == 0 or next;\n                    push(@list, $v) if !$seen{$v}++;\n                }\n            }\n\n            return;\n        }\n\n        foreach my $p (@{primes($lo, $hi)}) {\n\n            $base % $p == 0 and next;\n\n            my $val = valuation($p - 1, 2);\n            $val > $k_exp                                                   or next;\n            powmod($base, ($p - 1) >> ($val - $k_exp), $p) == ($congr % $p) or next;\n\n            my $z = znorder($base, $p);\n            gcd($m, $z) == 1 or next;\n\n            for (my ($q, $v) = ($p, $m * $p) ; $v <= $B ; ($q, $v) = ($q * $p, $v * $p)) {\n\n                if ($q > $p) {\n                    powmod($base, $z, $q) == 1 or last;\n                }\n\n                __SUB__->($v, lcm($L, $z), $p + 1, $j - 1, $k_exp, $congr);\n            }\n        }\n    };\n\n    # Case where 2^d == 1 (mod p), where d is the odd part of p-1.\n    $generator->(1, 1, 2, $k, 0, 1);\n\n    # Cases where 2^(d * 2^v) == -1 (mod p), for some v >= 0.\n    foreach my $v (0 .. logint($B, 2)) {\n        $generator->(1, 1, 2, $k, $v, -1);\n    }\n\n    return sort { $a <=> $b } @list;\n}\n\n# Generate all the Fermat pseudoprimes to base 3 in range [1, 10^5]\n\nmy $from = 1;\nmy $upto = 1e5;\nmy $base = 3;\n\nmy @arr;\nforeach my $k (1 .. 100) {\n    last if pn_primorial($k) > $upto;\n    push @arr, strong_fermat_pseudoprimes_in_range($from, $upto, $k, $base);\n}\n\nsay join(', ', sort { $a <=> $b } @arr);\n\n# Run some tests\n\nif (0) {    # true to run some tests\n    foreach my $k (1 .. 5) {\n\n        say \"Testing k = $k\";\n\n        my $lo           = pn_primorial($k);\n        my $hi           = mulint($lo, 10000);\n        my $omega_primes = omega_primes($k, $lo, $hi);\n\n        foreach my $base (2 .. 100) {\n            my @this = grep { is_strong_pseudoprime($_, $base) and !is_prime($_) } @$omega_primes;\n            my @that = strong_fermat_pseudoprimes_in_range($lo, $hi, $k, $base);\n            join(' ', @this) eq join(' ', @that)\n              or die \"Error for k = $k and base = $base with hi = $hi\\n(@this) != (@that)\";\n        }\n    }\n}\n\n__END__\n121, 703, 1891, 3281, 8401, 8911, 10585, 12403, 16531, 18721, 19345, 23521, 31621, 44287, 47197, 55969, 63139, 74593, 79003, 82513, 87913, 88573, 97567\n"
  },
  {
    "path": "Math/strong_fermat_pseudoprimes_in_range_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 24 September 2022\n# https://github.com/trizen\n\n# Generate all the k-omega strong Fermat pseudoprimes in range [A,B]. (not in sorted order)\n\n# Definition:\n#   k-omega primes are numbers n such that omega(n) = k.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Almost_prime\n#   https://en.wikipedia.org/wiki/Prime_omega_function\n#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html\n\n=for comment\n\n# PARI/GP program (slow):\n\nstrong_fermat_psp(A, B, k, base) = A=max(A, vecprod(primes(k))); (f(m, l, p, j, k_exp, congr) = my(list=List()); forprime(q=p, sqrtnint(B\\m, j), if(base%q != 0, my(tv=valuation(q-1, 2)); if(tv > k_exp && Mod(base, q)^(((q-1)>>tv)<<k_exp) == congr, my(v=m*q, t=q, r=nextprime(q+1)); while(v <= B, my(L=lcm(l, znorder(Mod(base, t)))); if(gcd(L, v) == 1, if(j==1, if(v>=A && if(k==1, !isprime(v), 1) && (v-1)%L == 0, listput(list, v)), if(v*r <= B, list=concat(list, f(v, L, r, j-1, k_exp, congr)))), break); v *= q; t *= q)))); list); my(r=f(1, 1, 2, k, 0, 1)); for(v=0, logint(B, 2), r=concat(r, f(1, 1, 2, k, v, -1))); vecsort(Vec(r));\n\n# PARI/GP program (fast):\n\nstrong_check(p, base, e, r) = my(tv=valuation(p-1, 2)); tv > e && Mod(base, p)^((p-1)>>(tv-e)) == r;\nstrong_fermat_psp(A, B, k, base) = A=max(A, vecprod(primes(k))); (f(m, l, lo, k, e, r) = my(list=List()); my(hi=sqrtnint(B\\m, k)); if(lo > hi, return(list)); if(k==1, forstep(p=lift(1/Mod(m, l)), hi, l, if(isprimepower(p) && gcd(m*base, p) == 1 && strong_check(p, base, e, r), my(n=m*p); if(n >= A && (n-1) % znorder(Mod(base, p)) == 0, listput(list, n)))), forprime(p=lo, hi, base%p == 0 && next; strong_check(p, base, e, r) || next; my(z=znorder(Mod(base, p))); gcd(m,z) == 1 || next; my(q=p, v=m*p); while(v <= B, list=concat(list, f(v, lcm(l, z), p+1, k-1, e, r)); q *= p; Mod(base, q)^z == 1 || break; v *= p))); list); my(res=f(1, 1, 2, k, 0, 1)); for(v=0, logint(B, 2), res=concat(res, f(1, 1, 2, k, v, -1))); vecsort(Set(res));\n\n=cut\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory 0.74 qw(:all);\n\nsub strong_fermat_pseudoprimes_in_range ($A, $B, $k, $base) {\n\n    $A = vecmax($A, pn_primorial($k));\n\n    $A = Math::GMPz->new(\"$A\");\n    $B = Math::GMPz->new(\"$B\");\n\n    my $u = Math::GMPz::Rmpz_init();\n    my $v = Math::GMPz::Rmpz_init();\n\n    my %seen;\n    my @list;\n\n    my $generator = sub ($m, $L, $lo, $j, $k_exp, $congr) {\n\n        Math::GMPz::Rmpz_tdiv_q($u, $B, $m);\n        Math::GMPz::Rmpz_root($u, $u, $j);\n\n        my $hi = Math::GMPz::Rmpz_get_ui($u);\n\n        if ($lo > $hi) {\n            return;\n        }\n\n        if ($j == 1) {\n\n            Math::GMPz::Rmpz_invert($v, $m, $L);\n\n            if (Math::GMPz::Rmpz_cmp_ui($v, $hi) > 0) {\n                return;\n            }\n\n            if (Math::GMPz::Rmpz_fits_ulong_p($L)) {\n                $L = Math::GMPz::Rmpz_get_ui($L);\n            }\n\n            my $t = Math::GMPz::Rmpz_get_ui($v);\n            $t > $hi && return;\n            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);\n\n            for (my $p = $t ; $p <= $hi ; $p += $L) {\n\n                if (is_prime_power($p) and Math::GMPz::Rmpz_gcd_ui($Math::GMPz::NULL, $m, $p) == 1 and gcd($base, $p) == 1) {\n\n                    my $val = valuation($p - 1, 2);\n                    $val > $k_exp                                                   or next;\n                    powmod($base, ($p - 1) >> ($val - $k_exp), $p) == ($congr % $p) or next;\n\n                    Math::GMPz::Rmpz_mul_ui($v, $m, $p);\n\n                    if ($k == 1 and is_prime($p) and Math::GMPz::Rmpz_cmp_ui($m, 1) == 0) {\n                        ## ok\n                    }\n                    elsif (Math::GMPz::Rmpz_cmp($v, $A) >= 0) {\n                        Math::GMPz::Rmpz_sub_ui($u, $v, 1);\n                        if (Math::GMPz::Rmpz_divisible_ui_p($u, znorder($base, $p))) {\n                            push(@list, Math::GMPz::Rmpz_init_set($v)) if !$seen{Math::GMPz::Rmpz_get_str($v, 10)}++;\n                        }\n                    }\n                }\n            }\n\n            return;\n        }\n\n        my $u   = Math::GMPz::Rmpz_init();\n        my $v   = Math::GMPz::Rmpz_init();\n        my $lcm = Math::GMPz::Rmpz_init();\n\n        foreach my $p (@{primes($lo, $hi)}) {\n\n            $base % $p == 0 and next;\n\n            my $val = valuation($p - 1, 2);\n            $val > $k_exp                                                   or next;\n            powmod($base, ($p - 1) >> ($val - $k_exp), $p) == ($congr % $p) or next;\n\n            my $z = znorder($base, $p);\n            Math::GMPz::Rmpz_gcd_ui($Math::GMPz::NULL, $m, $z) == 1 or next;\n            Math::GMPz::Rmpz_lcm_ui($lcm, $L, $z);\n\n            Math::GMPz::Rmpz_set_ui($u, $p);\n\n            for (Math::GMPz::Rmpz_mul_ui($v, $m, $p) ; Math::GMPz::Rmpz_cmp($v, $B) <= 0 ; Math::GMPz::Rmpz_mul_ui($v, $v, $p)) {\n                __SUB__->($v, $lcm, $p + 1, $j - 1, $k_exp, $congr);\n                Math::GMPz::Rmpz_mul_ui($u, $u, $p);\n                powmod($base, $z, $u) == 1 or last;\n            }\n        }\n    };\n\n    # Case where 2^d == 1 (mod p), where d is the odd part of p-1.\n    $generator->(Math::GMPz->new(1), Math::GMPz->new(1), 2, $k, 0, 1);\n\n    # Cases where 2^(d * 2^v) == -1 (mod p), for some v >= 0.\n    foreach my $v (0 .. logint($B, 2)) {\n        $generator->(Math::GMPz->new(1), Math::GMPz->new(1), 2, $k, $v, -1);\n    }\n\n    return sort { $a <=> $b } @list;\n}\n\n# Generate all the strong Fermat pseudoprimes to base 3 in range [1, 10^5]\n\nmy $from = 1;\nmy $upto = 1e5;\nmy $base = 3;\n\nmy @arr;\nforeach my $k (1 .. 100) {\n    last if pn_primorial($k) > $upto;\n    push @arr, strong_fermat_pseudoprimes_in_range($from, $upto, $k, $base);\n}\n\nsay join(', ', sort { $a <=> $b } @arr);\n\n# Run some tests\n\nif (0) {    # true to run some tests\n    foreach my $k (1 .. 5) {\n\n        say \"Testing k = $k\";\n\n        my $lo           = pn_primorial($k) * 4;\n        my $hi           = mulint($lo, 1000);\n        my $omega_primes = omega_primes($k, $lo, $hi);\n\n        foreach my $base (2 .. 100) {\n            my @this = grep { is_strong_pseudoprime($_, $base) and !is_prime($_) } @$omega_primes;\n            my @that = strong_fermat_pseudoprimes_in_range($lo, $hi, $k, $base);\n            join(' ', @this) eq join(' ', @that)\n              or die \"Error for k = $k and base = $base with hi = $hi\\n(@this) != (@that)\";\n        }\n    }\n}\n\n__END__\n121, 703, 1891, 3281, 8401, 8911, 10585, 12403, 16531, 18721, 19345, 23521, 31621, 44287, 47197, 55969, 63139, 74593, 79003, 82513, 87913, 88573, 97567\n"
  },
  {
    "path": "Math/sub-unit_squares.pl",
    "content": "#!/usr/bin/perl\n\n# Efficient algorithm for generating sub-unit squares.\n\n# A sub-unit square is a square number that remains a square after having a 1 subtracted from each digit in the square.\n\n# See also:\n#   https://oeis.org/A061844\n#   https://rosettacode.org/wiki/Sub-unit_squares\n\nuse 5.036;\nuse ntheory      qw(:all);\nuse Math::GMP    qw(:constant);\n#use Math::AnyNum qw(:overload);\n\nsub difference_of_two_squares_solutions ($n) {    # solutions x to x^2 - y^2 = n\n\n    my @solutions;\n    my $limit = sqrtint($n);\n\n    foreach my $divisor (divisors($n)) {\n\n        last if $divisor > $limit;\n\n        my $p = $divisor;\n        my $q = $n / $divisor;\n\n        ($p + $q) % 2 == 0 or next;\n\n        my $x = ($q + $p) >> 1;\n        unshift @solutions, $x;\n    }\n\n    return @solutions;\n}\n\nmy $N    = 34;         # how many terms to compute\nmy %seen = (1 => 1);\n\nmy $index = 1;\nsay($index, ': ', 1);\n\nOUTER: for (my $n = 1 ; ; ++$n) {\n\n    my $r = (10**$n - 1) / 9;\n\n    foreach my $x (difference_of_two_squares_solutions($r)) {\n\n        my $xsqr = $x**2;\n        my @d    = todigits($xsqr);\n\n        next if $d[0] == 1;\n        next if !vecall { $_ } @d;\n        next if !is_square(fromdigits([map { $_ - 1 } @d]));\n\n        if (!$seen{$xsqr}++) {\n            say(++$index, ': ', $xsqr);\n            last OUTER if ($index >= $N);\n        }\n    }\n}\n\n__END__\n1: 1\n2: 36\n3: 3136\n4: 24336\n5: 5973136\n6: 71526293136\n7: 318723477136\n8: 264779654424693136\n9: 24987377153764853136\n10: 31872399155963477136\n11: 58396845218255516736\n12: 517177921565478376336\n13: 252815272791521979771662766736\n14: 518364744896318875336864648336\n15: 554692513628187865132829886736\n16: 658424734191428581711475835136\n17: 672475429414871757619952152336\n18: 694688876763154697414122245136\n19: 711197579293752874333735845136\n20: 975321699545235187287523246336\n21: 23871973274358556957126877486736\n22: 25347159162241162461433882565136\n23: 34589996454813135961785697637136\n24: 2858541763747552538199941619545257144336\n25: 214785886789716796533667464535274377236736\n26: 233292528132679183463629157143235636286736\n27: 244671849793441155421899813243325528686736\n28: 271571567929448516411695557685613529966736\n29: 322388381596588665613523969581347191316736\n30: 385414415625146742626881165526237149942336\n31: 494827714874767379344736911473964125592336\n32: 729191918879671448289782722539515523333136\n33: 739265858539339252384919139328667324488336\n34: 451616391374794616993675837721511769881724292768597136\n"
  },
  {
    "path": "Math/sum_factorial.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 13th October 2013\n# https://trizenx.blogspot.com\n\n# This script generates sums of consecutive numbers for factorial numbers.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub sum_x {\n    my ($x, $y, $z) = @_;\n    ($x + $y) * (($y - $x) / $z + 1) / 2;\n}\n\nsub factorial {\n    my ($n) = @_;\n\n    my $fact = 1;\n    $fact *= $_ for 2 .. $n;\n\n    $fact;\n}\n\nforeach my $i (1 .. 9) {\n    my $fact = factorial($i);\n\n  O: for (my $o = 1 ; $o <= int sqrt($fact) ; $o++) {\n      N: for (my $n = 1 ; $n <= $fact ; $n++) {\n          M: for (my $m = $n ; $m <= $fact ; $m++) {\n\n                my $sum = sum_x($n, $m, $o);\n\n                if ($sum == $fact) {\n                    printf \"%2d. %10d:%5d %10d .. %d\\n\", $i, $fact, $o, $n, $m;\n                }\n            }\n        }\n\n        last if $o >= 1;\n    }\n\n    say '';\n}\n"
  },
  {
    "path": "Math/sum_of_an_even_number_of_positive_squares.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 24 October 2017\n# https://github.com/trizen\n\n# Algorithm for representing a positive integer `n` as a sum of an even number of positive squares.\n\n# Example:\n#   9925 = 5^2 * 397\n#   9925 = (3^2 + 4^2) * (6^2 + 19^2)\n#   9925 = 18^2 + 24^2 + 57^2 + 76^2\n\n# This algorithm is efficient when the factorization of `n` is known.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(sqrtmod factor_exp vecprod vecsum forsetproduct);\n\nsub primitive_sum_of_two_squares ($p) {\n\n    if ($p == 2) {\n        return [1, 1];\n    }\n\n    my $s = sqrtmod($p - 1, $p) || return;\n    my $q = $p;\n\n    while ($s * $s > $p) {\n        ($s, $q) = ($q % $s, $s);\n    }\n\n    return [$s, $q % $s];\n}\n\nsub sum_of_squares_solution ($n) {\n\n    my @primitives;\n    my $left_prod = 1;\n\n    foreach my $f (factor_exp($n)) {\n        if ($f->[0] % 4 == 3) {            # p = 3 (mod 4)\n            $f->[1] % 2 == 0 or return;    # power must be even\n            $left_prod *= $f->[0]**($f->[1] >> 1);\n        }\n        elsif ($f->[0] == 2) {             # p = 2\n            if ($f->[1] % 2 == 0) {        # power is even\n                $left_prod *= $f->[0]**($f->[1] >> 1);\n            }\n            else {                         # power is odd\n                push @primitives, [1, 1];\n                $left_prod *= $f->[0]**(($f->[1] - 1) >> 1);\n            }\n        }\n        else {                             # p = 1 (mod 4)\n            push @primitives, primitive_sum_of_two_squares($f->[0]**$f->[1]);\n        }\n    }\n\n    my @solution;\n\n    forsetproduct {\n        push @solution, vecprod($left_prod, @_);\n    } @primitives;\n\n    return sort { $a <=> $b } @solution;\n}\n\nforeach my $n (1..1e5) {\n    (my @solution = sum_of_squares_solution($n)) || next;\n\n    say \"$n = \", join(' + ', map { \"$_^2\" } @solution);\n\n    # Verify solution\n    if ((my $sum = vecsum(map { $_**2 } @solution)) != $n) {\n        die \"error for $n -> $sum\";\n    }\n}\n\n__END__\n99872 = 156^2 + 156^2 + 160^2 + 160^2\n99873 = 108^2 + 297^2\n99874 = 116^2 + 116^2 + 191^2 + 191^2\n99877 = 79^2 + 306^2\n99881 = 5^2 + 316^2\n99892 = 28^2 + 32^2 + 42^2 + 48^2 + 112^2 + 128^2 + 168^2 + 192^2\n99901 = 26^2 + 315^2\n99905 = 8^2 + 12^2 + 16^2 + 20^2 + 24^2 + 28^2 + 30^2 + 40^2 + 42^2 + 56^2 + 60^2 + 70^2 + 84^2 + 105^2 + 140^2 + 210^2\n99908 = 208^2 + 238^2\n99909 = 39^2 + 66^2 + 156^2 + 264^2\n99914 = 111^2 + 111^2 + 194^2 + 194^2\n99917 = 24^2 + 30^2 + 196^2 + 245^2\n99920 = 60^2 + 120^2 + 128^2 + 256^2\n99929 = 220^2 + 227^2\n99937 = 36^2 + 96^2 + 105^2 + 280^2\n99944 = 124^2 + 124^2 + 186^2 + 186^2\n99945 = 42^2 + 84^2 + 135^2 + 270^2\n99954 = 144^2 + 144^2 + 171^2 + 171^2\n99956 = 10^2 + 316^2\n99961 = 156^2 + 275^2\n99965 = 48^2 + 96^2 + 133^2 + 266^2\n99970 = 24^2 + 24^2 + 36^2 + 36^2 + 48^2 + 48^2 + 50^2 + 50^2 + 72^2 + 72^2 + 75^2 + 75^2 + 100^2 + 100^2 + 150^2 + 150^2\n99972 = 174^2 + 264^2\n99973 = 10^2 + 17^2 + 160^2 + 272^2\n99976 = 82^2 + 82^2 + 208^2 + 208^2\n99977 = 16^2 + 64^2 + 75^2 + 300^2\n99985 = 26^2 + 52^2 + 139^2 + 278^2\n99986 = 68^2 + 68^2 + 213^2 + 213^2\n99989 = 217^2 + 230^2\n99994 = 16^2 + 16^2 + 30^2 + 30^2 + 104^2 + 104^2 + 195^2 + 195^2\n99997 = 171^2 + 266^2\n100000 = 152^2 + 152^2 + 164^2 + 164^2\n"
  },
  {
    "path": "Math/sum_of_digits.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 12 May 2018\n# https://github.com/trizen\n\n# Two algorithms for computing the sum of the digits of an integer, in a given base.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse Math::AnyNum qw(idiv divmod irand sumdigits ipow2);\n\nsub sumdigits_1 ($n, $k) {\n\n    my $N = $n;\n    my $S = 0;\n\n    while ($n >= 1) {\n        $n = idiv($n, $k);\n        $S += $n;\n    }\n\n    return ($N - $S * ($k - 1));\n}\n\nsub sumdigits_2 ($n, $k) {\n\n    my $m = 0;\n    my $S = 0;\n\n    while ($n >= 1) {\n        ($n, $m) = divmod($n, $k);\n        $S += $m;\n    }\n\n    return $S;\n}\n\nmy $n = irand(2, ipow2(100000));\nmy $k = irand(2, 1000);\n\nsay sumdigits($n, $k);    # provided by Math::AnyNum\nsay sumdigits_1($n, $k);\nsay sumdigits_2($n, $k);\n"
  },
  {
    "path": "Math/sum_of_digits_subquadratic_algorithm.pl",
    "content": "#!/usr/bin/perl\n\n# Subquadratic algorithm for computing the sum of digits of a given integer in a given base.\n\n# Based on the FastIntegerOutput algorithm presented in the book:\n#\n#   Modern Computer Arithmetic\n#           - by Richard P. Brent and Paul Zimmermann\n#\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub FastSumOfDigits ($A, $B) {\n\n    # Find k such that B^(2k - 2) <= A < B^(2k)\n    my $k = (logint($A, $B) >> 1) + 1;\n\n    sub ($A, $k) {\n\n        if ($A < $B) {\n            return $A;\n        }\n\n        my ($Q, $R) = divrem($A, powint($B, $k));\n        my $t = ($k + 1) >> 1;\n\n        vecsum(__SUB__->($Q, $t), __SUB__->($R, $t));\n    }->($A, $k);\n}\n\nforeach my $B (2 .. 100) {    # run some tests\n    my $N = factorial($B);    # int(rand(~0));\n\n    my $x = vecsum(todigits($N, $B));\n    my $y = FastSumOfDigits($N, $B);\n\n    if ($x != $y) {\n        die \"Error for: FastSumOfDigits($N, $B)\";\n    }\n}\n\nsay join ', ', FastSumOfDigits(5040, 10);    #=> 9\nsay join ', ', FastSumOfDigits(5040, 11);    #=> 20\nsay join ', ', FastSumOfDigits(5040, 12);    #=> 13\nsay join ', ', FastSumOfDigits(5040, 13);    #=> 24\n"
  },
  {
    "path": "Math/sum_of_digits_subquadratic_algorithm_mpz.pl",
    "content": "#!/usr/bin/perl\n\n# Subquadratic algorithm for computing the sum of digits of a given integer in a given base.\n\n# Based on the FastIntegerOutput algorithm presented in the book:\n#\n#   Modern Computer Arithmetic\n#           - by Richard P. Brent and Paul Zimmermann\n#\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub FastSumOfDigits ($A, $B) {\n\n    $A = Math::GMPz->new(\"$A\");\n\n    # Find k such that B^(2k - 2) <= A < B^(2k)\n    my $k = (logint($A, $B) >> 1) + 1;\n\n    my $Q = Math::GMPz::Rmpz_init();\n    my $R = Math::GMPz::Rmpz_init();\n\n    sub ($A, $k) {\n\n        if (Math::GMPz::Rmpz_cmp_ui($A, $B) < 0) {\n            return Math::GMPz::Rmpz_get_ui($A);\n        }\n\n        my $w = ($k + 1) >> 1;\n        my $t = Math::GMPz::Rmpz_init();\n\n        Math::GMPz::Rmpz_ui_pow_ui($t, $B, $k);\n        Math::GMPz::Rmpz_divmod($Q, $R, $A, $t);\n        Math::GMPz::Rmpz_set($t, $Q);\n\n        __SUB__->($R, $w) + __SUB__->($t, $w);\n    }->($A, $k);\n}\n\nforeach my $B (2 .. 300) {    # run some tests\n    my $N = factorial($B);    # int(rand(~0));\n\n    my $x = vecsum(todigits($N, $B));\n    my $y = FastSumOfDigits($N, $B);\n\n    if ($x != $y) {\n        die \"Error for FastSumOfDigits($N, $B): $x != $y\";\n    }\n}\n\nsay join ', ', FastSumOfDigits(5040, 10);    #=> 9\nsay join ', ', FastSumOfDigits(5040, 11);    #=> 20\nsay join ', ', FastSumOfDigits(5040, 12);    #=> 13\nsay join ', ', FastSumOfDigits(5040, 13);    #=> 24\n"
  },
  {
    "path": "Math/sum_of_k-powerful_numbers_in_range.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 28 February 2021\n# Edit: 11 April 2024\n# https://github.com/trizen\n\n# Fast recursive algorithm for computing the sum of k-powerful numbers in a given range [A,B].\n# A positive integer n is considered k-powerful, if for every prime p that divides n, so does p^k.\n\n# Example:\n#   2-powerful = a^2 * b^3,             for a,b >= 1\n#   3-powerful = a^3 * b^4 * c^5,       for a,b,c >= 1\n#   4-powerful = a^4 * b^5 * c^6 * d^7, for a,b,c,d >= 1\n\n# OEIS:\n#   https://oeis.org/A001694 -- 2-powerful numbers\n#   https://oeis.org/A036966 -- 3-powerful numbers\n#   https://oeis.org/A036967 -- 4-powerful numbers\n#   https://oeis.org/A069492 -- 5-powerful numbers\n#   https://oeis.org/A069493 -- 6-powerful numbers\n\n# See also:\n#   https://oeis.org/A118896 -- Number of powerful numbers <= 10^n.\n\nuse 5.036;\nuse ntheory 0.74 qw(:all);\nuse Math::AnyNum qw(faulhaber_sum);\n\nsub powerful_sum_in_range ($A, $B, $k = 2) {\n\n    return 0 if ($A > $B);\n\n    my $sum = 0;\n\n    sub ($m, $r) {\n\n        my $from = 1;\n        my $upto = rootint(divint($B, $m), $r);\n\n        if ($r <= $k) {\n\n            if ($A > $m) {\n\n                # Optimization by Dana Jacobsen (from Math::Prime::Util::PP)\n                my $l = cdivint($A, $m);\n                if (($l >> $r) == 0) {\n                    $from = 2;\n                }\n                else {\n                    $from = rootint($l, $r);\n                    $from++ if (powint($from, $r) != $l);\n                }\n            }\n\n            return if ($from > $upto);\n            $sum += $m * (faulhaber_sum($upto, $r) - faulhaber_sum($from - 1, $r));\n            return;\n        }\n\n        foreach my $v ($from .. $upto) {\n            gcd($m, $v) == 1   or next;\n            is_square_free($v) or next;\n            __SUB__->(mulint($m, powint($v, $r)), $r - 1);\n        }\n      }\n      ->(1, 2 * $k - 1);\n\n    return $sum;\n}\n\nrequire Math::Sidef;\n\nforeach my $k (2 .. 10) {\n\n    my $lo = int rand powint(10, $k - 1);\n    my $hi = int rand powint(10, $k);\n\n    my $c1 = powerful_sum_in_range($lo, $hi, $k);\n    my $c2 = Math::Sidef::powerful_sum($k, $lo, $hi);\n\n    $c1 eq $c2 or die \"Error for [$lo, $hi] -- ($c1 != $c2)\\n\";\n\n    printf(\"Sum of %2d-powerful in range 10^j .. 10^(j+1): {%s}\\n\",\n           $k, join(\", \", map { powerful_sum_in_range(powint(10, $_), powint(10, $_ + 1), $k) } 0 .. $k + 7));\n}\n\n__END__\nSum of  2-powerful in range 10^j .. 10^(j+1): {22, 502, 19545, 628164, 20656197, 668961441, 21437300251, 685328369991, 21824118507902, 693905863243612}\nSum of  3-powerful in range 10^j .. 10^(j+1): {9, 220, 6121, 136410, 3529846, 80934268, 1811337810, 41811161255, 929876351992, 20679545550210, 457363233598112}\nSum of  4-powerful in range 10^j .. 10^(j+1): {1, 193, 2493, 60370, 1440893, 26780053, 516891583, 9990376094, 193432085418, 3626702483663, 68456092587576, 1272728145913757}\nSum of  5-powerful in range 10^j .. 10^(j+1): {1, 96, 1868, 35009, 746121, 14039356, 230448956, 4041417437, 70765409052, 1214243920880, 21187881376824, 365947199216587, 6015063920839580}\nSum of  6-powerful in range 10^j .. 10^(j+1): {1, 64, 1625, 24108, 427138, 7503765, 142877197, 2128546916, 37085174023, 547117264876, 9207435088386, 149796088225544, 2342746880282546, 36741577488049351}\nSum of  7-powerful in range 10^j .. 10^(j+1): {1, 0, 896, 24108, 271545, 4519876, 93259499, 1349452792, 22365106723, 310086289407, 4736025082478, 73612282993023, 1102078225069540, 16970183647609915, 262120890688576034}\nSum of  8-powerful in range 10^j .. 10^(j+1): {1, 0, 768, 21921, 193420, 2016717, 56385643, 851106512, 14014480848, 205584890161, 3186168004038, 43689401756765, 641512327279056, 9291932808199869, 136568208040185109, 2007778182656517551}\nSum of  9-powerful in range 10^j .. 10^(j+1): {1, 0, 512, 15360, 193420, 1626092, 33824682, 596581840, 8827764302, 147389799084, 2165109680321, 29580803725639, 409447338905006, 5697214477371426, 78740331560394730, 1144313243099576141, 15965319118886658764}\nSum of 10-powerful in range 10^j .. 10^(j+1): {1, 0, 0, 15360, 173737, 1626092, 31871557, 284130441, 5610671182, 106206715265, 1591481398917, 21833753103320, 298489744207556, 3892787043427942, 50393901956156445, 725082729912431153, 9766175708618550818, 140084863743264508627}\n"
  },
  {
    "path": "Math/sum_of_natural_powers_in_constant_base.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 17 September 2016\n# Website: https://github.com/trizen\n\n# Sum of increasing powers in constant base.\n\n# Example:\n#    ∑b^i for 0 ≤ i ≤ n == cf(b, n)\n#\n# where `b` can be any real number != 1.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub cf {\n    my ($base, $n) = @_;\n    ($base ** ($n+1) - 1) / ($base-1);\n}\n\nsay cf(3, 13);\nsay cf(-10.5, 4);\nsay cf(3.1415926535897932384626433832795, 10);\n"
  },
  {
    "path": "Math/sum_of_perfect_powers.pl",
    "content": "#!/usr/bin/perl\n\n# Efficient formula for computing the sum of perfect powers <= n.\n\n# Formula:\n#   a(n) = faulhaber(n,1) - Sum_{1..floor(log_2(n))} mu(k) * (faulhaber(floor(n^(1/k)), k) - 1)\n#        = 1 - Sum_{2..floor(log_2(n))} mu(k) * (faulhaber(floor(n^(1/k)), k) - 1)\n#\n# where:\n#   faulhaber(n,k) = Sum_{j=1..n} j^k.\n\n# See also:\n#   https://oeis.org/A069623\n\nuse 5.036;\nuse ntheory      qw(moebius);\nuse Math::AnyNum qw(faulhaber_sum sum ipow iroot ilog2);\n\nsub perfect_power_sum ($n) {\n    1 - sum(map { moebius($_) * (faulhaber_sum(iroot($n, $_), $_) - 1) } 2 .. ilog2($n));\n}\n\nforeach my $n (0 .. 15) {\n    printf(\"a(10^%d) = %s\\n\", $n, perfect_power_sum(ipow(10, $n)));\n}\n\n__END__\na(10^0) = 1\na(10^1) = 22\na(10^2) = 452\na(10^3) = 13050\na(10^4) = 410552\na(10^5) = 11888199\na(10^6) = 361590619\na(10^7) = 11120063109\na(10^8) = 345454923761\na(10^9) = 10800726331772\na(10^10) = 338846269199225\na(10^11) = 10659098451968490\na(10^12) = 335867724220740686\na(10^13) = 10595345580446344714\na(10^14) = 334502268562161605300\na(10^15) = 10566065095217905939231\n"
  },
  {
    "path": "Math/sum_of_prime-power_exponents_of_factorial.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 15 January 2019\n# https://github.com/trizen\n\n# Efficient program for computing the sum of exponents in prime-power factorization of n!.\n\n# See also:\n#   https://oeis.org/A022559    -- Sum of exponents in prime-power factorization of n!.\n#   https://oeis.org/A071811    -- Sum_{k <= 10^n} number of primes (counted with multiplicity) dividing k\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub sum_of_exponents_of_factorial ($n) {\n\n    return 0 if ($n <= 1);\n\n    my $s = sqrtint($n);\n    my $u = divint($n, $s+1);\n\n    my $total = 0;\n    my $prev  = prime_power_count($n);\n\n    for my $k (1 .. $s) {\n        my $curr = prime_power_count(divint($n, ($k + 1)));\n        $total += $k * ($prev - $curr);\n        $prev = $curr;\n    }\n\n    forprimes {\n        for (my $q = $_; $q <= $u; $q *= $_) {\n            $total += divint($n, $q);\n        }\n    } $u;\n\n    return $total;\n}\n\nsub sum_of_exponents_of_factorial_2 ($n) {\n\n    my $s = sqrtint($n);\n    my $total = 0;\n\n    for my $k (1 .. $s) {\n        $total += prime_power_count(divint($n,$k));\n        $total += divint($n,$k) if is_prime_power($k);\n    }\n\n    $total -= prime_power_count($s) * $s;\n\n    return $total;\n}\n\nforeach my $k (1 .. 11) {       # takes ~4s\n    say \"a(10^$k) = \", sum_of_exponents_of_factorial(powint(10,$k));\n}\n\n__END__\na(10^1)  = 15\na(10^2)  = 239\na(10^3)  = 2877\na(10^4)  = 31985\na(10^5)  = 343614\na(10^6)  = 3626619\na(10^7)  = 37861249\na(10^8)  = 392351272\na(10^9)  = 4044220058\na(10^10) = 41518796555\na(10^11) = 424904645958\na(10^12) = 4337589196099\na(10^13) = 44189168275565\n"
  },
  {
    "path": "Math/sum_of_prime-power_exponents_of_product_of_binomials.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 15 January 2019\n# https://github.com/trizen\n\n# Program for computing the sum of the exponents in prime-power factorization of Product_{k=0..n} binomial(n, k).\n\n#~ a(10^1) = 33\n#~ a(10^2) = 1847\n#~ a(10^3) = 94677\n#~ a(10^4) = 6344339\n#~ a(10^5) = 481640842\n#~ a(10^6) = 39172738473\n#~ a(10^7) = 3310162914057\n\n# See also:\n#   https://oeis.org/A323444\n\n# Paper:\n#   Jeffrey C. Lagarias, Harsh Mehta\n#   Products of binomial coefficients and unreduced Farey fractions\n#   https://arxiv.org/abs/1409.4145\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(factor);\n\nsub sum_of_exponents_of_product_of_binomials {\n    my ($n) = @_;\n\n    return 0 if ($n <= 1);\n\n    my ($r, $t) = (0, 0);\n\n    foreach my $k (1 .. $n) {\n        my $z = factor($k);\n        $t += $z;\n        $r += $k * $z - $t;\n    }\n\n    return $r;\n}\n\nforeach my $k (1 .. 7) {\n    say \"a(10^$k) = \", sum_of_exponents_of_product_of_binomials(10**$k);\n}\n"
  },
  {
    "path": "Math/sum_of_prime_powers.pl",
    "content": "#!/usr/bin/perl\n\n# Three sublinear algorithms for computing the sum of prime powers <= n,\n# based on the sublinear algorithm for computing the sum of primes <= n.\n\n# See also:\n#   https://oeis.org/A074793\n\nuse 5.036;\nuse Math::GMPz;\nuse ntheory                qw(:all);\nuse Math::Prime::Util::GMP qw(faulhaber_sum);\n\nsub sum_of_primes ($n, $k = 1) {    # Sum_{p prime <= n} p^k\n\n    return sum_primes($n) if ($k == 1);    # optimization\n\n    $n > ~0 and return undef;\n    $n <= 1 and return 0;\n\n    my $r = sqrtint($n);\n    my @V = map { divint($n, $_) } 1 .. $r;\n    push @V, CORE::reverse(1 .. $V[-1] - 1);\n\n    my $t = Math::GMPz::Rmpz_init_set_ui(0);\n    my $u = Math::GMPz::Rmpz_init();\n\n    my %S;\n    @S{@V} = map { Math::GMPz::Rmpz_init_set_str(faulhaber_sum($_, $k), 10) } @V;\n\n    foreach my $p (2 .. $r) {\n        if ($S{$p} > $S{$p - 1}) {\n            my $cp = $S{$p - 1};\n            my $p2 = $p * $p;\n            Math::GMPz::Rmpz_ui_pow_ui($t, $p, $k);\n            foreach my $v (@V) {\n                last if ($v < $p2);\n                Math::GMPz::Rmpz_sub($u, $S{divint($v, $p)}, $cp);\n                Math::GMPz::Rmpz_submul($S{$v}, $u, $t);\n            }\n        }\n    }\n\n    $S{$n} - 1;\n}\n\nsub sum_of_prime_powers ($n) {\n\n    # a(n) = Sum_{p prime <= n} p\n    # b(n) = Sum_{p prime <= n^(1/2)} p^2\n    # c(n) = Sum_{p prime <= n^(1/3)} f(p)\n\n    # sum_of_prime_powers(n) = a(n) + b(n) + c(n)\n\n    my $ps1 = sum_of_primes($n);\n    my $ps2 = sum_of_primes(sqrtint($n), 2);\n\n    # f(p) = (Sum_{k=1..floor(log_p(n))} p^k) - p^2 - p\n    #      = (p^(1+floor(log_p(n))) - 1)/(p-1) - p^2 - p - 1\n\n    my $ps3 = 0;\n    foreach my $p (@{primes(rootint($n, 3))}) {\n        $ps3 += divint(powint($p, logint($n, $p) + 1) - 1, $p - 1) - $p * $p - $p - 1;\n    }\n\n    return vecsum($ps1, $ps2, $ps3);\n}\n\nsub sum_of_prime_powers_2 ($n) {\n\n    # a(n) = Sum_{p prime <= n} p\n    # b(n) = Sum_{p prime <= n^(1/2)} f(p)\n\n    # sum_of_prime_powers(n) = a(n) + b(n)\n\n    my $ps1 = sum_of_primes($n);\n\n    # f(p) = (Sum_{k=1..floor(log_p(n))} p^k) - p\n    #      = (p^(1+floor(log_p(n))) - 1)/(p-1) - p - 1\n\n    my $ps2 = 0;\n    forprimes {\n        $ps2 += divint(powint($_, logint($n, $_) + 1) - 1, $_ - 1) - $_ - 1;\n    } sqrtint($n);\n\n    return vecsum($ps1, $ps2);\n}\n\nsub sum_of_prime_powers_3 ($n) {\n\n    # a(n) = Sum_{k=1..floor(log_2(n))} Sum_{p prime <= n^(1/k)} p^k.\n    vecsum(map { sum_of_primes(rootint($n, $_), $_) } 1 .. logint($n, 2));\n}\n\nforeach my $n (0 .. 10) {\n    say \"a(10^$n) = \", sum_of_prime_powers(powint(10, $n));\n}\n\nforeach my $k (1 .. 100) {\n    my $n = int(rand(1e3)) + 1;\n\n    my $x = sum_of_prime_powers($n);\n    my $y = sum_of_prime_powers_2($n);\n    my $z = sum_of_prime_powers_3($n);\n\n    $x == $y or die \"error\";\n    $x == $z or die \"error\";\n}\n\n__END__\na(10^0) = 0\na(10^1) = 38\na(10^2) = 1375\na(10^3) = 82674\na(10^4) = 5850315\na(10^5) = 457028152\na(10^6) = 37610438089\na(10^7) = 3204814813355\na(10^8) = 279250347324393\na(10^9) = 24740607755154524\na(10^10) = 2220853189506845580\na(10^11) = 201467948093608962539\na(10^12) = 18435613572072500152927\n"
  },
  {
    "path": "Math/sum_of_primes_generalized.pl",
    "content": "#!/usr/bin/perl\n\n# Simple implementation of the prime-summation function:\n#   Sum_{p prime <= n} p^k, for any fixed k >= 0.\n\nuse 5.020;\nuse warnings;\nuse experimental qw(signatures);\n\nuse Math::GMPz;\nuse ntheory qw(divint sqrtint);\nuse Math::Prime::Util::GMP qw(faulhaber_sum);\n\nsub sum_of_primes ($n, $k = 1) {\n\n    $n > ~0 and return undef;\n    $n <= 1 and return 0;\n\n    my $r = sqrtint($n);\n    my @V = map { divint($n, $_) } 1 .. $r;\n    push @V, CORE::reverse(1 .. $V[-1] - 1);\n\n    my $t = Math::GMPz::Rmpz_init_set_ui(0);\n    my $u = Math::GMPz::Rmpz_init();\n\n    my %S;\n    @S{@V} = map { Math::GMPz::Rmpz_init_set_str(faulhaber_sum($_, $k), 10) } @V;\n\n    foreach my $p (2 .. $r) {\n        if ($S{$p} > $S{$p - 1}) {\n            my $cp = $S{$p - 1};\n            my $p2 = $p * $p;\n            Math::GMPz::Rmpz_ui_pow_ui($t, $p, $k);\n            foreach my $v (@V) {\n                last if ($v < $p2);\n                Math::GMPz::Rmpz_sub($u, $S{divint($v, $p)}, $cp);\n                Math::GMPz::Rmpz_submul($S{$v}, $u, $t);\n            }\n        }\n    }\n\n    $S{$n} - 1;\n}\n\nsay sum_of_primes(100, 0);      #=> 25\nsay sum_of_primes(1e8);         #=> 279209790387276\nsay sum_of_primes(1e8, 2);      #=> 18433608754948081174274\n"
  },
  {
    "path": "Math/sum_of_sigma.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 10 January 2018\n# https://github.com/trizen\n\n# Sum of the sigma(k) function, for 1 <= k <= n, where `sigma(k)` is `Sum_{d|k} d`.\n\n# See also:\n#   https://oeis.org/A024916\n#   https://oeis.org/A072692\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(faulhaber_sum isqrt);\n\nsub partial_sum_of_sigma {    # O(sqrt(n)) complexity\n    my ($n) = @_;\n\n    my $s = isqrt($n);\n    my $u = int($n / ($s + 1));\n\n    my $sum  = 0;\n    my $prev = faulhaber_sum($n, 1);    # n-th triangular number\n\n    foreach my $k (1 .. $s) {\n        my $curr = faulhaber_sum(int($n/($k+1)), 1);\n        $sum += $k * ($prev - $curr);\n        $prev = $curr;\n    }\n\n    foreach my $k (1 .. $u) {\n        $sum += $k * int($n / $k);\n    }\n\n    return $sum;\n}\n\nforeach my $k (0 .. 10) {\n    say \"a(10^$k) = \", partial_sum_of_sigma(10**$k);\n}\n\n__END__\na(10^0) = 1\na(10^1) = 87\na(10^2) = 8299\na(10^3) = 823081\na(10^4) = 82256014\na(10^5) = 8224740835\na(10^6) = 822468118437\na(10^7) = 82246711794796\na(10^8) = 8224670422194237\na(10^9) = 822467034112360628\n"
  },
  {
    "path": "Math/sum_of_sigma_2.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 10 January 2018\n# https://github.com/trizen\n\n# Sum of the sigma_2(k) function, for 1 <= k <= n, where `sigma_2(k)` is `Sum_{d|k} d^2`.\n\n# See also:\n#   https://oeis.org/A188138\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(isqrt faulhaber_sum);\n\nsub partial_sum_of_sigma2 {    # O(sqrt(n)) complexity\n    my ($n) = @_;\n\n    my $s = isqrt($n);\n    my $u = int($n / ($s + 1));\n\n    my $sum  = 0;\n    my $prev = faulhaber_sum($n, 2);\n\n    foreach my $k (1 .. $s) {\n        my $curr = faulhaber_sum(int($n / ($k + 1)), 2);\n        $sum += $k * ($prev - $curr);\n        $prev = $curr;\n    }\n\n    foreach my $k (1 .. $u) {\n        $sum += $k * $k * int($n / $k);\n    }\n\n    return $sum;\n}\n\nforeach my $k (0 .. 9) {\n    say \"a(10^$k) = \", partial_sum_of_sigma2(10**$k);\n}\n\n__END__\na(10^0) = 1\na(10^1) = 469\na(10^2) = 407819\na(10^3) = 401382971\na(10^4) = 400757638164\na(10^5) = 400692683389101\na(10^6) = 400686363385965077\na(10^7) = 400685705322499946270\na(10^8) = 400685641565621401132515\na(10^9) = 400685635084923815073475174\n"
  },
  {
    "path": "Math/sum_of_the_number_of_divisors.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 18 August 2017\n# https://github.com/trizen\n\n# Sum of the number of divisors, `d(k)`, for 1 <= k <= n.\n\n# Formula with O(sqrt(n)) complexity:\n#   Sum_{k=1..n} d(k) = (2 * Sum_{k=1..floor(sqrt(n))} floor(n/k)) - floor(sqrt(n))^2\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub sum_of_sigma0 {\n    my ($n) = @_;\n\n    my $s = int(sqrt($n));\n\n    my $sum = 0;\n    foreach my $k (1 .. $s) {\n        $sum += int($n / $k);\n    }\n\n    $sum *= 2;\n    $sum -= $s**2;\n\n    return $sum;\n}\n\nsay sum_of_sigma0(100);      #=> 482\nsay sum_of_sigma0(1234);     #=> 8979\nsay sum_of_sigma0(98765);    #=> 1151076\n"
  },
  {
    "path": "Math/sum_of_the_number_of_divisors_of_gcd_x_y.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 10 January 2019\n# https://github.com/trizen\n\n# Fast formula for computing:\n#   a(n) = sum of the number of divisors of gcd(x,y) with x*y <= n.\n\n# See also:\n#   https://oeis.org/A268732    -- Sum of the numbers of divisors of gcd(x,y) with x*y <= n.\n#   https://oeis.org/A034444    -- Partial sums of A034444: sum of number of unitary divisors from 1 to n.\n#   https://oeis.org/A180361    -- Sum of number of unitary divisors (A034444) from 1 to 10^n\n\n# Adrian Dudek, on the Success of Mishandling Euclid's Lemma:\n#   https://arxiv.org/abs/1602.03555\n\n# Asymptotic formula:\n#   a(n) ~ 1/6 * π^2 * n * (2 * (-12 * log(A) + γ + log(2) + log(π)) + log(n) + 2*γ - 1) + O(sqrt(n)*log(n))\n#\n# where γ is the Euler-Mascheroni constant and \"A\" is the Glaisher-Kinkelin constant.\n\n# Alternative asymptotic formula:\n#   a(n) ~ (n * zeta(2) * (log(n) + 2*γ - 1 + c)) + O(sqrt(n)*log(n))\n#\n#  where γ is the Euler-Mascheroni and c = 2*Zeta'(2)/Zeta(2) = -1.1399219861890656127997287200...\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(moebius);\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload pi EulerGamma isqrt zeta round);\n\nsub asymptotic_formula($n) {\n\n    # c = 2*Zeta'(2)/Zeta(2) = (12 * Zeta'(2))/π^2 = 2*(-12*log(A) + γ + log(2) + log(π))\n    my $c = -1.13992198618906561279972872003946000480696456161386195911639472087583455473348121357;\n\n    # Asymptotic formula based on Merten's theorem (1874) (see: https://oeis.org/A064608)\n    ($n * zeta(2) * (log($n) + 2 * EulerGamma + $c - 1));\n}\n\nsub asymptotic_formula2($n) {\n\n    # The Glaisher-Kinkelin constant\n    my $A = 1.28242712910062263687534256886979172776768892732500119206374002174040630885882646112973649195820237439420646120399;\n\n    # Asymptotic formula in terms of the Glaisher-Kinkelin constant\n    zeta(2) * $n * (2 * (-12 * log($A) + EulerGamma + log(2*pi)) + log($n) + 2*EulerGamma - 1);\n}\n\nsub sum_of_number_of_divisors_of_gcd ($n) {    # based on formula by Jerome Raulin (https://oeis.org/A064608)\n\n    my $total = 0;\n\n    foreach my $k (1 .. isqrt($n)) {\n        my $t = 0;\n        foreach my $j (1 .. isqrt($n / ($k * $k))) {\n            $t += int($n / ($j * $k * $k));\n        }\n\n        my $r = isqrt($n / ($k * $k));\n        $total += (2 * $t - $r * $r);\n    }\n\n    return $total;\n}\n\nsay join(', ', map { sum_of_number_of_divisors_of_gcd($_) } 1 .. 20);\n\nforeach my $k (1 .. 8) {\n\n    my $n = 10**$k;\n    my $t = sum_of_number_of_divisors_of_gcd($n);\n    my $u = asymptotic_formula($n);\n\n    printf(\"a(10^%s) = %10s ~ %-15s -> %s\\n\", $k, $t, round($u, -2), $t / $u);\n}\n\n__END__\n[0, 1, 3, 5, 9, 11, 15, 17, 23, 27, 31, 33, 41, 43, 47, 51, 60, 62, 70, 72, 80]\n\na(10^1)  =                31 ~ 21.66                -> 1.43085716814724731567697388362262512087796085132\na(10^2)  =               629 ~ 595.41               -> 1.05640884486870073219427770179934635115325018838\na(10^3)  =              9823 ~ 9741.73              -> 1.00834196073027036381381492602216565392721426965\na(10^4)  =            135568 ~ 135293.35            -> 1.00202999682691312076763529313619057317755443274\na(10^5)  =           1732437 ~ 1731693.62           -> 1.00042928187585922855456102384841804396816671626\na(10^6)  =          21107131 ~ 21104536.81          -> 1.00012292075282086768302929969619689628662614091\na(10^7)  =         248928748 ~ 248921374.75         -> 1.00002962076965424120327637576433900637540389794\na(10^8)  =        2867996696 ~ 2867973813.70        -> 1.00000797855916535575678041071686222727851109258\na(10^9)  =       32467409097 ~ 32467338798.29       -> 1.00000216521302261846703873643427029189711363986\na(10^10) =      362549612240 ~ 362549394595.78      -> 1.00000060031604804834071744691960444929352043683\na(10^11) =     4004254692640 ~ 4004254012086.08     -> 1.00000016995772897612356184672572401706556174343\na(10^12) =    43830142939380 ~ 43830140782143.61    -> 1.00000004921810301432497497420018745129768545890\na(10^13) =   476177421208658 ~ 476177414434264.13   -> 1.00000001422661735697513455710167585383336332082\na(10^14) =  5140534231877816 ~ 5140534210470921.03  -> 1.00000000416433275074901946766616776434113033877\na(10^15) = 55192942833495679 ~ 55192942765992007.53 -> 1.00000000122304896383936291361582837193299642341\n"
  },
  {
    "path": "Math/sum_of_the_number_of_unitary_divisors.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 10 January 2019\n# https://github.com/trizen\n\n# Two fast algorithms for computing the sum of number of unitary divisors from 1 to n.\n#   a(n) = Sum_{k=1..n} usigma_0(k)\n\n# Based on the formula:\n#   a(n) = Sum_{k=1..n} moebius(k)^2 * floor(n/k)\n\n# See also:\n#   https://oeis.org/A034444    -- Partial sums of A034444: sum of number of unitary divisors from 1 to n.\n#   https://oeis.org/A180361    -- Sum of number of unitary divisors (A034444) from 1 to 10^n\n#   https://oeis.org/A268732    -- Sum of the numbers of divisors of gcd(x,y) with x*y <= n.\n\n# Asymptotic formula:\n#   a(n) ~ n*log(n)/zeta(2) + O(n)\n\n# Better asymptotic formula:\n#   a(n) ~ (n/zeta(2))*(log(n) + 2*γ - 1 - c) + O(sqrt(n) * log(n))\n#\n# where γ is the Euler-Mascheroni constant and c = 2*zeta'(2)/zeta(2) = -1.1399219861890656127997287200...\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\nuse Math::AnyNum qw(:overload zeta EulerGamma round);\n\nsub squarefree_count ($n) {\n    my $count = 0;\n\n    my $k = 1;\n    foreach my $mu (moebius(1, sqrtint($n))) {\n        if ($mu) {\n            $count += $mu * divint($n, $k * $k);\n        }\n        ++$k;\n    }\n\n    return $count;\n}\n\nsub asymptotic_formula($n) {\n\n    # c = 2*Zeta'(2)/Zeta(2) = (12 * Zeta'(2))/π^2 = 2 (-12 log(A) + γ + log(2) + log(π))\n    my $c = -1.13992198618906561279972872003946000480696456161386195911639472087583455473348121357;\n\n    # Asymptotic formula based on Merten's theorem (1874) (see: https://oeis.org/A064608)\n    ($n / zeta(2)) * (log($n) + 2 * EulerGamma - 1 - $c);\n}\n\nsub unitary_divisors_partial_sum_1 ($n) {    # O(sqrt(n)) complexity\n\n    my $total = 0;\n\n    my $s = sqrtint($n);\n    my $u = divint($n, $s + 1);\n\n    my $prev = squarefree_count($n);\n\n    for my $k (1 .. $s) {\n        my $curr = squarefree_count(divint($n, $k + 1));\n        $total += $k * ($prev - $curr);\n        $prev = $curr;\n    }\n\n    forsquarefree {\n        $total += divint($n, $_);\n    } $u;\n\n    return $total;\n}\n\nsub unitary_divisors_partial_sum_2 ($n) {    # based on formula by Jerome Raulin (https://oeis.org/A064608)\n\n    my $total = 0;\n\n    my $k = 1;\n    foreach my $mu (moebius(1, sqrtint($n))) {\n        if ($mu) {\n\n            my $t = 0;\n            foreach my $j (1 .. sqrtint(divint($n, $k * $k))) {\n                $t += divint($n, $j * $k * $k);\n            }\n\n            my $r = sqrtint(divint($n, $k * $k));\n            $total += $mu * (2 * $t - $r * $r);\n        }\n        ++$k;\n    }\n\n    return $total;\n}\n\nsay join(', ', map { unitary_divisors_partial_sum_1($_) } 1 .. 20);\nsay join(', ', map { unitary_divisors_partial_sum_2($_) } 1 .. 20);\n\nforeach my $k (0 .. 7) {\n\n    my $n = 10**$k;\n    my $t = unitary_divisors_partial_sum_2($n);\n    my $u = asymptotic_formula($n);\n\n    printf(\"a(10^%s) = %10s ~ %-15s -> %s\\n\", $k, $t, round($u, -2), $t / $u);\n}\n\n__END__\n[0, 1, 3, 5, 7, 9, 13, 15, 17, 19, 23, 25, 29, 31, 35, 39, 41, 43, 47, 49, 53]\n[0, 1, 3, 5, 7, 9, 13, 15, 17, 19, 23, 25, 29, 31, 35, 39, 41, 43, 47, 49, 53]\n\na(10^0)  =            1 ~ 0.79            -> 1.27085398285349342897812915198984638968899591751\na(10^1)  =           23 ~ 21.87           -> 1.05182461403816051734935994402113331145060974294\na(10^2)  =          359 ~ 358.65          -> 1.00098140095602073835866744824992972185806123685\na(10^3)  =         4987 ~ 4986.28         -> 1.00014357239778054254970740667091143421188177813\na(10^4)  =        63869 ~ 63860.88        -> 1.00012715302552355451250212258735392366329621935\na(10^5)  =       778581 ~ 778589.19       -> 0.999989484576929013867264739526374966823956960403\na(10^6)  =      9185685 ~ 9185695.75      -> 0.99999882923368455522780513812504287278271814501\na(10^7)  =    105854997 ~ 105854996.37    -> 1.00000000598372061072117962943109677794267023891\na(10^8)  =   1198530315 ~ 1198530351.90   -> 0.999999969211002320383540850995519903094748492418\na(10^9)  =  13385107495 ~ 13385107401.37  -> 1.00000000699496540213133746406895764726726792391\na(10^10) = 147849112851 ~ 147849112837.28 -> 1.00000000009281141854332921757852421030396550125\n"
  },
  {
    "path": "Math/sum_of_the_sum_of_divisors.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 19 August 2017\n# https://github.com/trizen\n\n# Sum of the sum of divisors, `sigma(k)`, for 1 <= k <= n.\n\n# Algorithm due to Peter Polm (August 18, 2014) (see: A024916).\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub sum_of_sigma {\n    my ($n) = @_;\n\n    my $s = 0;\n    my $d = 1;\n    my $q = $n;\n\n    for (; $d < $q ; ++$d, $q = int($n / $d)) {\n        $s += $q * (2 * $d + $q + 1) >> 1;\n    }\n\n    $s - $d * ($d * ($d - 1) >> 1) + ($q * ($q + 1) >> 1);\n}\n\nsay sum_of_sigma(13);       #=> 141\nsay sum_of_sigma(64);       #=> 3403\nsay sum_of_sigma(1234);     #=> 1252881\nsay sum_of_sigma(10**8);    #=> 8224670422194237\n"
  },
  {
    "path": "Math/sum_of_three_cubes_problem.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 01 June 2016\n# Website: https://github.com/trizen\n\n# An attempt at creating a new algorithm for finding\n# integer solutions to the following equation: x^3 + y^3 + z^3 = n\n\n# The concept of the algorithm is to use modular exponentiation,\n# based on the relations:\n#\n#       (x^3 mod n) + (y^3 mod n) + (z^3 mod n) = n\n# or:\n#       (x^3 mod n) + (y^3 mod n) + (z^3 mod n) = 2n       ; this is more common (?)\n#\n\n# This leads to the following conjecture:\n#       x = a * n + k\n#       y = b * n + j\n#\n# for every term x and y in a valid equation: x^3 + y^3 + z^3 = n\n\n# Less generally, we can say:\n#\n#       x = a * n + s1 + psum(P(k))\n#       y = b * n + s2 + psum(P(k))\n\n# where `s1` and `s2` are the starting points for the corresponding terms\n# and `psum(P(k))` is a partial sum of the remainders of n in the form: (k^3 mod n).\n\n# Example:\n#    39 = 134476^3 + 117367^3 - 159380^3\n#\n#    39 = 1 + 13 + 25\n#\n#    P(1)  = {15, 6, 18}                ; returned by get_pos_steps(39, 1)\n#    P(13) = {35}                       ; returned by get_pos_steps(39, 13)\n#    P(25) = {6, 15, 18}                ; returned by get_pos_steps(39, 25)\n#\n#    s1 = 1                             ; returned by get_pos_steps(39, 1)\n#    s2 = 4                             ; returned by get_pos_steps(39, 25)\n#    s3 = 13                            ; returned by get_pos_steps(39, 13)\n#\n#    117367 = a * 39 + s1 + 15\n#    134476 = b * 39 + s2 + 0\n#   -159380 = c * 39 + s3 + 0\n#\n# then we find:\n#    a =  3009\n#    b =  3448\n#    c = -4087\n#\n# which results to:\n#    117367 =  3009 * 39 + 16\n#    134476 =  3448 * 39 + 4\n#   -159380 = -4087 * 39 + 13\n#\n\n# For n=74:\n#\n#   2*74 = 68 + 29 + 51\n#\n#   P(68) = {2, 52, 20}\n#   P(29) = {18, 24, 32}\n#   P(51) = {8, 6, 60}\n#\n#   s1 = 6\n#   s2 = 5\n#   s3 = 17\n#\n#   x = a * 74 + s1 + (2 + 52)\n#   y = b * 74 + s2 + (0)\n#   z = c * 74 + s3 + (18)\n#\n#   x = a * 74 + 60\n#   y = b * 74 + 5\n#   z = c * 74 + 35\n#\n#   a =  894997732304\n#   b =  3830406833753\n#   c = -3846625575080\n\n# We can also easily observe that any valid solution satisfies:\n#\n#    is_cube(x^3 + y^3 - n) or\n#    is_cube(x^3 - y^3 - n)\n#\n\n# Currently, in this code, we show how to calculate the steps\n# of a given term and how to collect and filter potential valid solutions.\n\n# To actually find a solution, more work is required...\n\n# Inspired by:\n#      https://www.youtube.com/watch?v=wymmCdLdPvM\n\n# See also:\n#   https://mathoverflow.net/questions/138886/which-integers-can-be-expressed-as-a-sum-of-three-cubes-in-infinitely-many-ways\n\nuse 5.014;\nuse strict;\nuse warnings;\n\n#use integer;\n#use Math::AnyNum qw(:overload);\n\nuse ntheory qw(powmod is_power);\nuse List::Util qw(pairmap any sum0);\n\nuse Data::Dump qw(pp);\n\n# (a^3 % 33) + (b^3 % 33) + (c^3 % 33) = 66\n\nsub get_pos_steps {\n    my ($n, $k) = @_;\n\n    my @steps;\n    foreach my $i (1 .. 2 * $n) {\n        if (powmod($i, 3, $n) == $k) {\n            push @steps, $i;\n        }\n    }\n\n    ($steps[0], [map { $steps[$_] - $steps[$_ - 1] } 1 .. $#steps]);\n}\n\nsub get_neg_steps {\n    my ($n, $k) = @_;\n\n    my @steps;\n    foreach my $i (1 .. 2 * $n) {\n        if (powmod(-$i, 3, $n) == $k) {\n            push @steps, -$i;\n        }\n    }\n\n    ($steps[0], [map { $steps[$_] - $steps[$_ - 1] } 1 .. $#steps]);\n}\n\nsub get_partitions {\n    my ($n) = @_;\n\n    my @p;\n    my %seen;\n    foreach my $i (1 .. $n) {\n        foreach my $j ($i .. $n - $i) {\n            foreach my $k ($j .. $n - $j - $i) {\n                if ($i + $j + $k == $n) {\n                    my $v = join(' ', sort { $a <=> $b } ($i, $j, $k));\n                    next if (exists $seen{$v});\n                    $seen{$v} = 1;\n                    push @p, [$i, $j, $k];\n                }\n            }\n        }\n    }\n\n    return @p;\n}\n\n#use Math::AnyNum qw(:overload);\n\n#~ my $n = 33;\n#~ my $x = 0;\n#~ my $y = 0;\n#~ my $z = 0;\n\n#~ my $n = 42;\n#~ my $x = 0;\n#~ my $y = 0;\n#~ my $z = 0;\n\n#~ my $n = 74;\n#~ my $x = 66229832190556;\n#~ my $y = 283450105697727;\n#~ my $z = -284650292555885;\n\n# First solution for n=33 was found by Andrew Booker\n# See also:\n#   https://people.maths.bris.ac.uk/~maarb/papers/cubesv1.pdf\n#   https://www.bradyharanblog.com/blog/33-and-the-sum-of-three-cubes\n\nmy $n = 33;\nmy $x = 8866128975287528;\nmy $y = -8778405442862239;\nmy $z = -2736111468807040;\n\nsay powmod($x, 3, 33) + powmod($y, 3, 33) + powmod($z, 3, 33);\n\n#~ my $n = 30;\n#~ my $x = 2_220_422_932;\n#~ my $y = -2_218_888_517;\n#~ my $z = -283_059_965;\n\n#~ my $n = 52;\n#~ my $x = -61922712865;\n#~ my $y = 23961292454;\n#~ my $z = 60702901317;\n\n#~ my $n = 75;\n#~ my $x = -435203231;\n#~ my $y = 435203083;\n#~ my $z = 4381159;\n\n#~ my $n = 75;\n#~ my $x = 2_576_191_140_760;\n#~ my $y = 1_217_343_443_218;\n#~ my $z = -2_663_786_047_493;\n\n#~ my $n = 75;\n#~ my $x = 59_897_299_698_355;\n#~ my $y = -47_258_398_396_091;\n#~ my $z = -47_819_328_945_509;\n\n#~ my $n = 87;\n#~ my $x = 4271;\n#~ my $y =-4126;\n#~ my $z = -1972;\n\n#~ my $n = 39;\n#~ my $x = -159380;\n#~ my $y = 134476;\n#~ my $z = 117367;\n\n#$x **= 3;\n#$y **= 3;\n#$z **= 3;\n\nmy @partitions = (get_partitions($n), get_partitions(2 * $n));\nmy @valid;\n\nF1: foreach my $p (@partitions) {\n    my @data;\n    foreach my $k (@{$p}) {\n        my $ok = 0;\n        my $data = {k => $k};\n\n        {\n            my ($start, $steps) = get_pos_steps($n, $k);\n            if (defined($start)) {\n                $ok ||= 1;\n                $data->{pos} = {\n                                start => $start,\n                                steps => $steps,\n                               };\n            }\n        }\n\n        {\n            my ($start, $steps) = get_neg_steps($n, $k);\n            if (defined($start)) {\n                $ok ||= 1;\n                $data->{neg} = {\n                                start => $start,\n                                steps => $steps,\n                               };\n            }\n        }\n        $ok || next F1;\n        push @data, $data;\n    }\n    push @valid, \\@data;\n}\n\n#\n## Experimenting with various optimization ideas\n#\nforeach my $solution (@valid) {\n    my $count = 0;\n    foreach my $k ($x, $y, $z) {\n        ++$count if any {\n            my $s = $_;\n\n            any {\n                (($k % $n) == sum0(@{$s->{pos}{steps}}[0 .. $_]) + $s->{pos}{start})\n                  or (($k % (-$n)) == sum0(@{$s->{neg}{steps}}[0 .. $_]) + $s->{neg}{start})\n            }\n            (-1 .. int(@{$s->{pos}{steps}} / 2) - 1);\n\n            #~ any {\n            #~ ($k % sum(@{$s->{pos}{steps}}[0 .. $_]) == $s->{pos}{start})\n            #~ or ($k % sum(@{$s->{neg}{steps}}[0 .. $_]) == $s->{neg}{start})\n            #~ }\n            #~ int(@{$s->{pos}{steps}} / 2) .. $#{$s->{pos}{steps}};\n\n            #(any      { $k % $_ == $s->{pos}{start} } @{$s->{pos}{steps}})\n            #or (any { $k % $_ == $s->{neg}{start} } @{$s->{neg}{steps}})\n        }\n        @{$solution};\n    }\n    if ($count >= 3) {\n        pp $solution;\n    }\n}\n\nsay scalar @valid;\n\nmy %seen;\npp [sort {$a <=> $b} grep{!$seen{$_}++} map { map {$_->{pos}{start}}@{$_} } @valid];\n"
  },
  {
    "path": "Math/sum_of_triangular_numbers_solutions.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 02 March 2018\n# https://github.com/trizen\n\n# Find representations for a given number (n) as a sum of three triangular\n# numbers, where the index (k) of one triangular number is also given.\n\n# Equivalent with finding solutions to `x` and `y` in the following equation:\n#\n#   n = k*(k+1)/2 + x*(x+1)/2 + y*(y+1)/2\n#\n# where `n` and `k` are given.\n\n# Example:\n#   n = 1234\n#   k = 42\n\n# Solutions:\n#   1234 = 42*(42+1)/2 +  3*( 3+1)/2 + 25*(25+1)/2\n#   1234 = 42*(42+1)/2 + 10*(10+1)/2 + 23*(23+1)/2\n#   1234 = 42*(42+1)/2 + 12*(12+1)/2 + 22*(22+1)/2\n\n# When k=0, `n` will be represented as a sum of two triangular numbers only (if possible):\n#   1234 = 17*(17+1)/2 + 46*(46+1)/2\n\n# See also:\n#   https://projecteuler.net/problem=621\n#   https://trizenx.blogspot.com/2017/10/representing-integers-as-sum-of-two.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(sqrtmod factor_exp chinese is_polygonal forsetproduct);\n\nsub sum_of_two_squares ($n) {\n\n    $n == 0 and return [0, 0];\n\n    my $prod1 = 1;\n    my $prod2 = 1;\n\n    my @prime_powers;\n\n    foreach my $f (factor_exp($n)) {\n        if ($f->[0] % 4 == 3) {            # p = 3 (mod 4)\n            $f->[1] % 2 == 0 or return;    # power must be even\n            $prod2 *= $f->[0]**($f->[1] >> 1);\n        }\n        elsif ($f->[0] == 2) {             # p = 2\n            if ($f->[1] % 2 == 0) {        # power is even\n                $prod2 *= $f->[0]**($f->[1] >> 1);\n            }\n            else {                         # power is odd\n                $prod1 *= $f->[0];\n                $prod2 *= $f->[0]**(($f->[1] - 1) >> 1);\n                push @prime_powers, [$f->[0], 1];\n            }\n        }\n        else {                             # p = 1 (mod 4)\n            $prod1 *= $f->[0]**$f->[1];\n            push @prime_powers, $f;\n        }\n    }\n\n    $prod1 == 1 and return [$prod2, 0];\n    $prod1 == 2 and return [$prod2, $prod2];\n\n    my %table;\n    foreach my $f (@prime_powers) {\n        my $pp = $f->[0]**$f->[1];\n        my $r = sqrtmod($pp - 1, $pp);\n        push @{$table{$pp}}, [$r, $pp], [$pp - $r, $pp];\n    }\n\n    my @square_roots;\n\n    forsetproduct {\n        push @square_roots, chinese(@_);\n    } values %table;\n\n    my @solutions;\n\n    foreach my $r (@square_roots) {\n\n        my $s = $r;\n        my $q = $prod1;\n\n        while ($s * $s > $prod1) {\n            ($s, $q) = ($q % $s, $s);\n        }\n\n        push @solutions, [$prod2 * $s, $prod2 * ($q % $s)];\n    }\n\n    foreach my $f (@prime_powers) {\n        for (my $i = $f->[1] % 2 ; $i < $f->[1] ; $i += 2) {\n\n            my $sq = $f->[0]**(($f->[1] - $i) >> 1);\n            my $pp = $f->[0]**($f->[1] - $i);\n\n            push @solutions, map {\n                [map { $sq * $prod2 * $_ } @$_]\n            } __SUB__->($prod1 / $pp);\n        }\n    }\n\n    return sort { $a->[0] <=> $b->[0] } do {\n        my %seen;\n        grep { !$seen{$_->[0]}++ } map {\n            [sort { $a <=> $b } @$_]\n        } @solutions;\n    };\n}\n\nsub sum_of_triangles ($n, $k) {\n\n    my $z = ($n - $k * ($k + 1) / 2) * 8 + 1;\n\n    return if $z <= 0;\n\n    my @result;\n    my @solutions = sum_of_two_squares($z + 1);\n\n    foreach my $s (@solutions) {\n\n        is_polygonal(($s->[0]**2 - 1)/8, 3, \\my $x);\n        is_polygonal(($s->[1]**2 - 1)/8, 3, \\my $y);\n\n        push @result, [$x, $y];\n    }\n\n    return @result;\n}\n\nmy $n = 1234;\nmy $k = 42;\n\nmy @solutions = sum_of_triangles($n, $k);\n\nforeach my $s (@solutions) {\n    say \"$n = $k*($k+1)/2 + $s->[0]*($s->[0]+1)/2 + $s->[1]*($s->[1]+1)/2\";\n}\n"
  },
  {
    "path": "Math/sum_of_two_primes.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 20 August 2015\n# Website: https://github.com/trizen\n\n# This script counts the numbers which CANNOT be written as the sum of two primes\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(primes);\n\nmy $primes = primes(10000);\nunshift @{$primes}, 1;    # consider 1 as being prime\n\nmy %seen;\nfor my $i (0 .. $#{$primes}) {\n    for my $j ($i .. $#{$primes}) {\n        undef $seen{$primes->[$i] + $primes->[$j]};\n    }\n}\n\nmy $count = 0;\nforeach my $n (1 .. 2 * $primes->[-1]) {\n    exists($seen{$n}) || ++$count;\n}\n\nsay \"$count numbers, from a total of \", 2 * $primes->[-1], \", CANNOT be written as the sum of two primes.\";\n\n__END__\n8772 numbers, from a total of 19946, CANNOT be written as the sum of two primes.\n"
  },
  {
    "path": "Math/sum_of_two_squares_all_solutions.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 25 October 2017\n# https://github.com/trizen\n\n# A recursive algorithm for finding all the non-negative integer solutions to the equation:\n#   a^2 + b^2 = n\n# for any given positive integer `n` for which such a solution exists.\n\n# Example:\n#   99025 = 41^2 + 312^2 = 48^2 + 311^2 = 95^2 + 300^2 = 104^2 + 297^2 = 183^2 + 256^2 = 220^2 + 225^2\n\n# This algorithm is efficient when the factorization of `n` can be computed.\n\n# Blog post:\n#   https://trizenx.blogspot.com/2017/10/representing-integers-as-sum-of-two.html\n\n# See also:\n#   https://oeis.org/A001481\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Math::GMPz;\nuse ntheory qw(sqrtmod factor_exp chinese forsetproduct);\n\nsub sum_of_two_squares_solutions ($n) {\n\n    $n < 0  and return;\n    $n == 0 and return [0, 0];\n\n    my %sqrtmod_cache;\n\n    my $find_solutions = sub ($factor_exp) {\n\n        my $prod1 = 1;\n        my $prod2 = 1;\n\n        my @prod1_factor_exp;\n\n        foreach my $f (@$factor_exp) {\n            my ($p, $e) = @$f;\n            if ($p % 4 == 3) {    # p = 3 (mod 4)\n                $e % 2 == 0 or return;    # power must be even\n                $prod2 *= Math::GMPz->new($p)**($e >> 1);\n            }\n            elsif ($p == 2) {             # p = 2\n                if ($e % 2 == 0) {        # power is even\n                    $prod2 *= Math::GMPz->new($p)**($e >> 1);\n                }\n                else {                    # power is odd\n                    $prod1 *= $p;\n                    $prod2 *= Math::GMPz->new($p)**(($e - 1) >> 1);\n                    push @prod1_factor_exp, [$p, 1];\n                }\n            }\n            else {                        # p = 1 (mod 4)\n                $prod1 *= Math::GMPz->new($p)**$e;\n                push @prod1_factor_exp, $f;\n            }\n        }\n\n        $prod1 == 1 and return [$prod2, 0];\n        $prod1 == 2 and return [$prod2, $prod2];\n\n        my @congruences;\n\n        foreach my $pe (@prod1_factor_exp) {\n            my ($p, $e) = @$pe;\n            my $pp  = Math::GMPz->new($p)**$e;\n            my $key = Math::GMPz::Rmpz_get_str($pp, 10);\n            my $r = (\n                $sqrtmod_cache{$key} //= sqrtmod(-1, $pp) // do {\n                    require Math::Sidef;\n                    Math::Sidef::sqrtmod(-1, $pp);\n                }\n            );\n            $r = Math::GMPz->new(\"$r\") if ref($r);\n            push @congruences, [[$r, $pp], [$pp - $r, $pp]];\n        }\n\n        my @square_roots;\n\n        forsetproduct {\n            push @square_roots, Math::GMPz->new(chinese(@_));\n        } @congruences;\n\n        my @solutions;\n\n        foreach my $r (@square_roots) {\n\n            my $s = $r;\n            my $q = $prod1;\n\n            while ($s * $s > $prod1) {\n                ($s, $q) = ($q % $s, $s);\n            }\n\n            push @solutions, [$prod2 * $s, $prod2 * ($q % $s)];\n        }\n\n        foreach my $pe (@prod1_factor_exp) {\n            my ($p, $e) = @$pe;\n\n            for (my $i = $e % 2 ; $i < $e ; $i += 2) {\n\n                my @factor_exp;\n                foreach my $pp (@prod1_factor_exp) {\n                    if ($pp->[0] == $p) {\n                        push(@factor_exp, [$p, $i]) if ($i > 0);\n                    }\n                    else {\n                        push @factor_exp, $pp;\n                    }\n                }\n\n                my $sq = $prod2 * Math::GMPz->new($p)**(($e - $i) >> 1);\n\n                push @solutions, map {\n                    [map { $_ * $sq } @$_]\n                } __SUB__->(\\@factor_exp);\n            }\n        }\n\n        return @solutions;\n    };\n\n    my @factor_exp = factor_exp($n);\n    my @solutions  = $find_solutions->(\\@factor_exp);\n\n    @solutions = sort { $a->[0] <=> $b->[0] } do {\n        my %seen;\n        grep { !$seen{$_->[0]}++ } map {\n            [sort { $a <=> $b } @$_]\n        } @solutions;\n    };\n\n    return @solutions;\n}\n\n# Run some tests\n\nuse Test::More tests => 6;\n\nis_deeply([sum_of_two_squares_solutions(2025)],   [[0, 45],  [27,  36]],);\nis_deeply([sum_of_two_squares_solutions(164025)], [[0, 405], [243, 324]]);\nis_deeply([sum_of_two_squares_solutions(99025)],  [[41, 312], [48, 311], [95, 300], [104, 297], [183, 256], [220, 225]]);\n\nis_deeply(\n          [grep { my @arr = sum_of_two_squares_solutions($_); @arr > 0 } -10 .. 160],\n          [0,   1,   2,   4,   5,   8,   9,   10,  13,  16,  17,  18,  20,  25,  26,  29,  32,  34,  36,  37,  40,  41,\n           45,  49,  50,  52,  53,  58,  61,  64,  65,  68,  72,  73,  74,  80,  81,  82,  85,  89,  90,  97,  98,  100,\n           101, 104, 106, 109, 113, 116, 117, 121, 122, 125, 128, 130, 136, 137, 144, 145, 146, 148, 149, 153, 157, 160\n          ]\n         );\n\ndo {\n    use bigint try => 'GMP';\n    is_deeply(\n              [sum_of_two_squares_solutions(Math::GMPz->new(\"11392163240756069707031250\"))],\n              [[39309472125,   3374998963875],\n               [216763660575,  3368260197225],\n               [477329304375,  3341305130625],\n               [729359177085,  3295481517405],\n               [735019741071,  3294223614297],\n               [907262616645,  3251005657515],\n               [982736803125,  3228992353125],\n               [1151205969375, 3172835964375],\n               [1224793301193, 3145162095999],\n               [1393801568775, 3074000720175],\n               [1622919634875, 2959441687125],\n               [1847545189875, 2824666354125],\n               [1993551800625, 2723584854375],\n               [2056446956025, 2676413487825],\n               [2194367046795, 2564549961435],\n               [2198769707673, 2560776252111],\n               [2386646521875, 2386646521875]\n              ]\n             );\n\n    is_deeply([sum_of_two_squares_solutions(2**128 + 1)],\n              [[1, 18446744073709551616], [8479443857936402504, 16382350221535464479]]);\n\n    is_deeply(\n              [sum_of_two_squares_solutions(13**18 * 5**7)],\n              [[75291211970,   2963091274585],\n               [100083884615,  2962357487570],\n               [124869548830,  2961416259815],\n               [149646468985,  2960267657230],\n               [154416779750,  2960022656375],\n               [179181003625,  2958626849750],\n               [203932680250,  2957023863625],\n               [228670076375,  2955213810250],\n               [253391459750,  2953196816375],\n               [258150241063,  2952784638466],\n               [282850264814,  2950521038023],\n               [307530481817,  2948050825694],\n               [332189163826,  2945374174457],\n               [356824584103,  2942491271746],\n               [481345955350,  2924702504425],\n               [505803171575,  2920572173350],\n               [530224968650,  2916237327575],\n               [554609636425,  2911698270650],\n               [578955467350,  2906955320425],\n               [583639307225,  2906018552450],\n               [607936593550,  2901032879225],\n               [632191308775,  2895844059550],\n               [656401754450,  2890452456775],\n               [680566235225,  2884858448450],\n               [802350873038,  2853386013959],\n               [826200069721,  2846571993278],\n               [849991411282,  2839558639801],\n               [873723231719,  2832346444642],\n               [897393869198,  2824935912839],\n               [901945120375,  2823486084250],\n               [925540625750,  2815839700375],\n               [949071319625,  2807996135750],\n               [972535554250,  2799955939625],\n               [977046452345,  2798385051790],\n               [1000429281410, 2790111094745],\n               [1023742054855, 2781641758610],\n               [1046983140190, 2772977636455],\n               [1070150909945, 2764119334990],\n               [1186462080890, 2716226499895],\n               [1209150070505, 2706203018090],\n               [1231753388710, 2695990032905],\n               [1254270452695, 2685588259510],\n               [1276699685690, 2674998426295],\n               [1281008818375, 2672937536750],\n               [1303331253250, 2662124398375],\n               [1325562421625, 2651124843250],\n               [1347700766750, 2639939641625],\n               [1369744738375, 2628569576750],\n               [1373978929622, 2626358804329],\n               [1395908335991, 2614769317862],\n               [1417739993098, 2602996730711],\n               [1439472372169, 2591041867258],\n               [1461103951382, 2578905564649],\n               [1569204922025, 2514592328950],\n               [1590192225050, 2501373094025],\n               [1611068173975, 2487978699050],\n               [1631831306950, 2474410081975],\n               [1652480170025, 2460668192950],\n               [1656443419150, 2458002007175],\n               [1676954116825, 2444054737150],\n               [1697347384850, 2429936320825],\n               [1717621795175, 2415647746850],\n               [1838087734327, 2325298292486],\n               [1857481600234, 2309835659287],\n               [1876745394953, 2294211278554],\n               [1895877769526, 2278426244393],\n               [1899547017625, 2275368057250],\n               [1918520912750, 2259392877625],\n               [1937360462375, 2243259482750],\n               [1956064347250, 2226969002375],\n               [1974631257625, 2210522577250],\n               [1978190975930, 2207337566135],\n               [1996592834665, 2190706671530],\n               [2014854880870, 2173922371465],\n               [2032975835735, 2156985841270],\n               [2050954430330, 2139898266935]\n              ]\n             )\n      if 0;\n};\n\nmy @nums = (@ARGV ? (map { Math::GMPz->new($_) } @ARGV) : (map { int rand(~0) } 1 .. 20));\n\nforeach my $n (@nums) {\n    (my @solutions = sum_of_two_squares_solutions($n)) || next;\n\n    say \"$n = \" . join(' = ', map { \"$_->[0]^2 + $_->[1]^2\" } @solutions);\n\n    # Verify solutions\n    foreach my $solution (@solutions) {\n        if ($n != $solution->[0]**2 + $solution->[1]**2) {\n            die \"error for $n: (@$solution)\\n\";\n        }\n    }\n}\n\n__END__\n999826 = 99^2 + 995^2 = 315^2 + 949^2 = 525^2 + 851^2 = 699^2 + 715^2\n999828 = 318^2 + 948^2\n999844 = 312^2 + 950^2 = 410^2 + 912^2\n999848 = 62^2 + 998^2\n999850 = 43^2 + 999^2 = 321^2 + 947^2 = 565^2 + 825^2\n999853 = 387^2 + 922^2\n999857 = 401^2 + 916^2 = 544^2 + 839^2\n999860 = 154^2 + 988^2 = 698^2 + 716^2\n999869 = 262^2 + 965^2 = 613^2 + 790^2\n999881 = 341^2 + 940^2 = 484^2 + 875^2\n999882 = 309^2 + 951^2 = 651^2 + 759^2\n999890 = 421^2 + 907^2 = 473^2 + 881^2\n999892 = 324^2 + 946^2\n999898 = 213^2 + 977^2 = 697^2 + 717^2\n999909 = 222^2 + 975^2 = 678^2 + 735^2\n999914 = 667^2 + 745^2\n999917 = 109^2 + 994^2\n999937 = 44^2 + 999^2 = 89^2 + 996^2\n999938 = 77^2 + 997^2\n999940 = 126^2 + 992^2 = 178^2 + 984^2 = 306^2 + 952^2 = 448^2 + 894^2 = 578^2 + 816^2 = 696^2 + 718^2\n999941 = 370^2 + 929^2 = 446^2 + 895^2\n999944 = 638^2 + 770^2\n999946 = 585^2 + 811^2\n999949 = 243^2 + 970^2 = 290^2 + 957^2 = 450^2 + 893^2 = 493^2 + 870^2\n999952 = 444^2 + 896^2\n999953 = 568^2 + 823^2\n999954 = 327^2 + 945^2 = 375^2 + 927^2\n999956 = 500^2 + 866^2\n999961 = 644^2 + 765^2\n999962 = 239^2 + 971^2 = 541^2 + 841^2\n999968 = 452^2 + 892^2\n999970 = 247^2 + 969^2 = 627^2 + 779^2\n999973 = 63^2 + 998^2 = 118^2 + 993^2 = 273^2 + 962^2 = 442^2 + 897^2 = 622^2 + 783^2 = 658^2 + 753^2\n999981 = 141^2 + 990^2\n999986 = 365^2 + 931^2 = 695^2 + 719^2\n999997 = 194^2 + 981^2 = 454^2 + 891^2\n1000000 = 0^2 + 1000^2 = 280^2 + 960^2 = 352^2 + 936^2 = 600^2 + 800^2\n"
  },
  {
    "path": "Math/sum_of_two_squares_all_solutions_2.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 22 November 2025\n# https://github.com/trizen\n\n# A fast algorithm for finding all the non-negative integer solutions to the equation:\n#   a^2 + b^2 = n\n# for any given positive integer `n` for which such a solution exists.\n\n# Example:\n#   99025 = 41^2 + 312^2 = 48^2 + 311^2 = 95^2 + 300^2 = 104^2 + 297^2 = 183^2 + 256^2 = 220^2 + 225^2\n\n# This algorithm is efficient when the factorization of `n` can be computed.\n\n# Blog post:\n#   https://trizenx.blogspot.com/2017/10/representing-integers-as-sum-of-two.html\n\n# See also:\n#   https://oeis.org/A001481\n\nuse 5.036;\nuse Math::GMPz qw();\nuse ntheory    qw(factor_exp sqrtmod powint);\n\n# Find a solution to x^2 + y^2 = p, for prime numbers `p` congruent to 1 mod 4.\nsub primitive_sum_of_two_squares ($p) {\n\n    if ($p == 2) {\n        return (1, 1);\n    }\n\n    my $s = Math::GMPz->new(sqrtmod(-1, $p) || return);\n    my $q = $p;\n\n    while ($s * $s > $p) {\n        ($s, $q) = ($q % $s, $s);\n    }\n\n    return ($s, $q % $s);\n}\n\n# Multiply two representations (a,b) and (c,d),\n# return all distinct sign/ordering variations.\nsub combine_pairs($A, $B, $C, $D) {\n#<<<\n    return (\n        [$A * $C - $B * $D, $A * $D + $B * $C],\n        [$A * $C + $B * $D, $A * $D - $B * $C],\n    );\n#>>>\n}\n\n# Multiply two *sets* of representations\nsub multiply_sets($A, $B) {\n    my %seen;\n    my @new;\n    for my $p (@$A) {\n        for my $q (@$B) {\n            for my $r (combine_pairs(@$p, @$q)) {\n                my ($x, $y) = @$r;\n\n                $x = -$x if ($x < 0);\n                $y = -$y if ($y < 0);\n\n                if ($x > $y) {\n                    ($x, $y) = ($y, $x);\n                }\n\n                my $key = \"$x,$y\";\n                next if $seen{$key}++;\n                push @new, [$x, $y];\n            }\n        }\n    }\n    return @new;\n}\n\nsub sum_of_two_squares_solutions($n) {\n\n    $n < 0  and return;\n    $n == 0 and return [0, 0];\n\n    my @factors = factor_exp($n);\n\n    # Start with representation of 1\n    my @reps = ([0, 1]);    # (0^2 + 1^2 = 1)\n\n    # Handle primes p ≡ 3 (mod 4) with even exponent: they contribute as a perfect square factor s^2.\n    # Multiply each (x,y) by s where s = product p^{e/2} over such primes.\n    my $square_scale = Math::GMPz->new(1);\n\n    foreach my $pp (@factors) {\n        my ($p, $k) = @$pp;\n\n        # Handle primes 3 mod 4\n        if ($p % 4 == 3) {\n            if ($k % 2 != 0) {\n                return;    # no solutions\n            }\n\n            # p^{2t} contributes factor (p^t)^2 which is a square; doesn't change reps aside from scaling\n            # We multiply by p^{k/2} as a scaling factor on both coordinates.\n            $square_scale *= powint($p, ($k >> 1));\n            next;\n        }\n\n        # Representation of p = x^2 + y^2\n        my ($x, $y) = primitive_sum_of_two_squares($p);\n\n        # Use binary exponentiation to get representations for p^k\n        my @acc   = ([0, 1]);\n        my @base  = ([$x, $y]);\n        my $exp_k = $k;\n\n        while ($exp_k > 0) {\n            if ($exp_k & 1) {\n                @acc = multiply_sets(\\@acc, \\@base);\n            }\n            @base = multiply_sets(\\@base, \\@base);\n            $exp_k >>= 1;\n        }\n        @reps = multiply_sets(\\@reps, \\@acc);\n    }\n\n    if ($square_scale != 1) {\n        @reps = map { [$_->[0] * $square_scale, $_->[1] * $square_scale] } @reps;\n    }\n\n    # Sort final reps\n    @reps = sort { $a->[0] <=> $b->[0] } map {\n        [sort { $a <=> $b } @$_]\n    } @reps;\n\n    return @reps;\n}\n\n# Run some tests\n\nuse Test::More tests => 8;\n\nis_deeply([sum_of_two_squares_solutions(2025)],   [[0, 45],  [27,  36]],);\nis_deeply([sum_of_two_squares_solutions(164025)], [[0, 405], [243, 324]]);\nis_deeply([sum_of_two_squares_solutions(99025)],  [[41, 312], [48, 311], [95, 300], [104, 297], [183, 256], [220, 225]]);\n\nis_deeply(\n          [grep { my @arr = sum_of_two_squares_solutions($_); @arr > 0 } -10 .. 160],\n          [0,   1,   2,   4,   5,   8,   9,   10,  13,  16,  17,  18,  20,  25,  26,  29,  32,  34,  36,  37,  40,  41,\n           45,  49,  50,  52,  53,  58,  61,  64,  65,  68,  72,  73,  74,  80,  81,  82,  85,  89,  90,  97,  98,  100,\n           101, 104, 106, 109, 113, 116, 117, 121, 122, 125, 128, 130, 136, 137, 144, 145, 146, 148, 149, 153, 157, 160\n          ]\n         );\n\nis_deeply(\n          [sum_of_two_squares_solutions(1777574759925022720)],\n          [[110080512, 1328705024],\n           [146744832, 1325156864],\n           [151045632, 1324673536],\n           [243249664, 1310879232],\n           [347689472, 1287123456],\n           [402252288, 1271128576],\n           [463025664, 1250272768],\n           [490100224, 1239909888],\n           [494122496, 1238312448],\n           [591927808, 1194653184],\n           [673967616, 1150366208],\n           [697867776, 1136026112],\n           [722402816, 1120584192],\n           [775551488, 1084478976],\n           [885287424, 996915712],\n           [912489984, 972078592]\n          ]\n         );\n\ndo {\n    use bigint try => 'GMP';\n    is_deeply(\n              [sum_of_two_squares_solutions(Math::GMPz->new(\"11392163240756069707031250\"))],\n              [[39309472125,   3374998963875],\n               [216763660575,  3368260197225],\n               [477329304375,  3341305130625],\n               [729359177085,  3295481517405],\n               [735019741071,  3294223614297],\n               [907262616645,  3251005657515],\n               [982736803125,  3228992353125],\n               [1151205969375, 3172835964375],\n               [1224793301193, 3145162095999],\n               [1393801568775, 3074000720175],\n               [1622919634875, 2959441687125],\n               [1847545189875, 2824666354125],\n               [1993551800625, 2723584854375],\n               [2056446956025, 2676413487825],\n               [2194367046795, 2564549961435],\n               [2198769707673, 2560776252111],\n               [2386646521875, 2386646521875]\n              ]\n             );\n\n    is_deeply([sum_of_two_squares_solutions(2**128 + 1)], [[1, 18446744073709551616], [8479443857936402504, 16382350221535464479]]);\n\n    is_deeply(\n              [sum_of_two_squares_solutions(13**18 * 5**7)],\n              [[75291211970,   2963091274585],\n               [100083884615,  2962357487570],\n               [124869548830,  2961416259815],\n               [149646468985,  2960267657230],\n               [154416779750,  2960022656375],\n               [179181003625,  2958626849750],\n               [203932680250,  2957023863625],\n               [228670076375,  2955213810250],\n               [253391459750,  2953196816375],\n               [258150241063,  2952784638466],\n               [282850264814,  2950521038023],\n               [307530481817,  2948050825694],\n               [332189163826,  2945374174457],\n               [356824584103,  2942491271746],\n               [481345955350,  2924702504425],\n               [505803171575,  2920572173350],\n               [530224968650,  2916237327575],\n               [554609636425,  2911698270650],\n               [578955467350,  2906955320425],\n               [583639307225,  2906018552450],\n               [607936593550,  2901032879225],\n               [632191308775,  2895844059550],\n               [656401754450,  2890452456775],\n               [680566235225,  2884858448450],\n               [802350873038,  2853386013959],\n               [826200069721,  2846571993278],\n               [849991411282,  2839558639801],\n               [873723231719,  2832346444642],\n               [897393869198,  2824935912839],\n               [901945120375,  2823486084250],\n               [925540625750,  2815839700375],\n               [949071319625,  2807996135750],\n               [972535554250,  2799955939625],\n               [977046452345,  2798385051790],\n               [1000429281410, 2790111094745],\n               [1023742054855, 2781641758610],\n               [1046983140190, 2772977636455],\n               [1070150909945, 2764119334990],\n               [1186462080890, 2716226499895],\n               [1209150070505, 2706203018090],\n               [1231753388710, 2695990032905],\n               [1254270452695, 2685588259510],\n               [1276699685690, 2674998426295],\n               [1281008818375, 2672937536750],\n               [1303331253250, 2662124398375],\n               [1325562421625, 2651124843250],\n               [1347700766750, 2639939641625],\n               [1369744738375, 2628569576750],\n               [1373978929622, 2626358804329],\n               [1395908335991, 2614769317862],\n               [1417739993098, 2602996730711],\n               [1439472372169, 2591041867258],\n               [1461103951382, 2578905564649],\n               [1569204922025, 2514592328950],\n               [1590192225050, 2501373094025],\n               [1611068173975, 2487978699050],\n               [1631831306950, 2474410081975],\n               [1652480170025, 2460668192950],\n               [1656443419150, 2458002007175],\n               [1676954116825, 2444054737150],\n               [1697347384850, 2429936320825],\n               [1717621795175, 2415647746850],\n               [1838087734327, 2325298292486],\n               [1857481600234, 2309835659287],\n               [1876745394953, 2294211278554],\n               [1895877769526, 2278426244393],\n               [1899547017625, 2275368057250],\n               [1918520912750, 2259392877625],\n               [1937360462375, 2243259482750],\n               [1956064347250, 2226969002375],\n               [1974631257625, 2210522577250],\n               [1978190975930, 2207337566135],\n               [1996592834665, 2190706671530],\n               [2014854880870, 2173922371465],\n               [2032975835735, 2156985841270],\n               [2050954430330, 2139898266935]\n              ]\n             );\n};\n\nmy @nums = (@ARGV ? (map { Math::GMPz->new($_) } @ARGV) : (map { int rand(~0) } 1 .. 20));\n\nforeach my $n (@nums) {\n    (my @solutions = sum_of_two_squares_solutions($n)) || next;\n\n    say \"$n = \" . join(' = ', map { \"$_->[0]^2 + $_->[1]^2\" } @solutions);\n\n    # Verify solutions\n    foreach my $solution (@solutions) {\n        if ($n != $solution->[0]**2 + $solution->[1]**2) {\n            die \"error for $n: (@$solution)\\n\";\n        }\n    }\n}\n"
  },
  {
    "path": "Math/sum_of_two_squares_all_solutions_tonelli-shanks.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 22 November 2025\n# https://github.com/trizen\n\n# A fast algorithm for finding all the non-negative integer solutions to the equation:\n#   a^2 + b^2 = n\n# for any given positive integer `n` for which such a solution exists.\n\n# Example:\n#   99025 = 41^2 + 312^2 = 48^2 + 311^2 = 95^2 + 300^2 = 104^2 + 297^2 = 183^2 + 256^2 = 220^2 + 225^2\n\n# This algorithm is efficient when the factorization of `n` can be computed.\n\n# Blog post:\n#   https://trizenx.blogspot.com/2017/10/representing-integers-as-sum-of-two.html\n\n# See also:\n#   https://oeis.org/A001481\n\nuse 5.036;\nuse Math::GMPz qw();\nuse ntheory    qw(:all);\n\n# Tonelli-Shanks: modular square root of n mod p (p odd prime)\n# Returns a root r such that r^2 ≡ n (mod p), or undef if none.\nsub tonelli_shanks ($n, $p) {\n\n    return 0 if $n == 0;\n\n    # check solution existence\n    return undef if kronecker($n, $p) == -1;    # == -1 mod p\n\n    $n %= $p;\n\n    # simple case p % 4 == 3\n    if ($p % 4 == 3) {\n        return powmod($n, ($p + 1) >> 2, $p);\n    }\n\n    # Factor p-1 = q * 2^s with q odd\n    my $q = $p - 1;\n    my $s = valuation($q, 2);\n    $q >>= $s;\n\n    # find a quadratic non-residue z\n    my $z = 2;\n    while (kronecker($z, $p) != -1) { $z++; }\n\n    my $c = powmod($z,                $q, $p);\n    my $r = powmod($n, ($q + 1) >> 1, $p);\n    my $t = powmod($n,                $q, $p);\n    my $m = $s;\n\n    while ($t != 1) {\n\n        # find least i (0 < i < m) such that t^(2^i) == 1\n        my $i  = 1;\n        my $tt = mulmod($t, $t, $p);\n        while ($i < $m && $tt != 1) {\n            $tt = mulmod($tt, $tt, $p);\n            $i++;\n        }\n        my $b = powmod($c, 1 << ($m - $i - 1), $p);\n        $r = mulmod($r, $b, $p);\n        $c = mulmod($b, $b, $p);\n        $t = mulmod($t, $c, $p);\n        $m = $i;\n    }\n    return $r;\n}\n\n# Find a solution to x^2 + y^2 = p, for prime numbers `p` congruent to 1 mod 4.\nsub primitive_sum_of_two_squares ($p) {\n\n    if ($p == 2) {\n        return (1, 1);\n    }\n\n    my $s = Math::GMPz->new(tonelli_shanks(-1, $p) || return);\n    my $q = $p;\n\n    while ($s * $s > $p) {\n        ($s, $q) = ($q % $s, $s);\n    }\n\n    return ($s, $q % $s);\n}\n\n# Multiply two representations (a,b) and (c,d),\n# return all distinct sign/ordering variations.\nsub combine_pairs($A, $B, $C, $D) {\n#<<<\n    return (\n        [$A * $C - $B * $D, $A * $D + $B * $C],\n        [$A * $C + $B * $D, $A * $D - $B * $C],\n    );\n#>>>\n}\n\n# Multiply two *sets* of representations\nsub multiply_sets($A, $B) {\n    my %seen;\n    my @new;\n    for my $p (@$A) {\n        for my $q (@$B) {\n            for my $r (combine_pairs(@$p, @$q)) {\n                my ($x, $y) = @$r;\n\n                $x = -$x if ($x < 0);\n                $y = -$y if ($y < 0);\n\n                if ($x > $y) {\n                    ($x, $y) = ($y, $x);\n                }\n\n                my $key = \"$x,$y\";\n                next if $seen{$key}++;\n                push @new, [$x, $y];\n            }\n        }\n    }\n    return @new;\n}\n\nsub sum_of_two_squares_solutions($n) {\n\n    $n < 0  and return;\n    $n == 0 and return [0, 0];\n\n    my @factors = factor_exp($n);\n\n    # Start with representation of 1\n    my @reps = ([0, 1]);    # (0^2 + 1^2 = 1)\n\n    # Handle primes p ≡ 3 (mod 4) with even exponent: they contribute as a perfect square factor s^2.\n    # Multiply each (x,y) by s where s = product p^{e/2} over such primes.\n    my $square_scale = Math::GMPz->new(1);\n\n    foreach my $pp (@factors) {\n        my ($p, $k) = @$pp;\n\n        # Handle primes 3 mod 4\n        if ($p % 4 == 3) {\n\n            if ($k % 2 != 0) {\n                return;    # no solutions\n            }\n\n            # p^{2t} contributes factor (p^t)^2 which is a square; doesn't change reps aside from scaling\n            # We multiply by p^{k/2} as a scaling factor on both coordinates.\n            $square_scale *= powint($p, $k >> 1);\n            next;\n        }\n\n        # Representation of p = x^2 + y^2\n        my ($x, $y) = primitive_sum_of_two_squares($p);\n\n        # Use binary exponentiation to get representations for p^k\n        my @acc   = ([0, 1]);\n        my @base  = ([$x, $y]);\n        my $exp_k = $k;\n\n        while ($exp_k > 0) {\n            if ($exp_k & 1) {\n                @acc = multiply_sets(\\@acc, \\@base);\n            }\n            @base = multiply_sets(\\@base, \\@base);\n            $exp_k >>= 1;\n        }\n        @reps = multiply_sets(\\@reps, \\@acc);\n    }\n\n    if ($square_scale != 1) {\n        @reps = map { [$_->[0] * $square_scale, $_->[1] * $square_scale] } @reps;\n    }\n\n    # Sort final reps\n    @reps = sort { $a->[0] <=> $b->[0] } map {\n        [sort { $a <=> $b } @$_]\n    } @reps;\n\n    return @reps;\n}\n\n# Run some tests\n\nuse Test::More tests => 8;\n\nis_deeply([sum_of_two_squares_solutions(2025)],   [[0, 45],  [27,  36]],);\nis_deeply([sum_of_two_squares_solutions(164025)], [[0, 405], [243, 324]]);\nis_deeply([sum_of_two_squares_solutions(99025)],  [[41, 312], [48, 311], [95, 300], [104, 297], [183, 256], [220, 225]]);\n\nis_deeply(\n          [grep { my @arr = sum_of_two_squares_solutions($_); @arr > 0 } -10 .. 160],\n          [0,   1,   2,   4,   5,   8,   9,   10,  13,  16,  17,  18,  20,  25,  26,  29,  32,  34,  36,  37,  40,  41,\n           45,  49,  50,  52,  53,  58,  61,  64,  65,  68,  72,  73,  74,  80,  81,  82,  85,  89,  90,  97,  98,  100,\n           101, 104, 106, 109, 113, 116, 117, 121, 122, 125, 128, 130, 136, 137, 144, 145, 146, 148, 149, 153, 157, 160\n          ]\n         );\n\nis_deeply(\n          [sum_of_two_squares_solutions(1777574759925022720)],\n          [[110080512, 1328705024],\n           [146744832, 1325156864],\n           [151045632, 1324673536],\n           [243249664, 1310879232],\n           [347689472, 1287123456],\n           [402252288, 1271128576],\n           [463025664, 1250272768],\n           [490100224, 1239909888],\n           [494122496, 1238312448],\n           [591927808, 1194653184],\n           [673967616, 1150366208],\n           [697867776, 1136026112],\n           [722402816, 1120584192],\n           [775551488, 1084478976],\n           [885287424, 996915712],\n           [912489984, 972078592]\n          ]\n         );\n\ndo {\n    use bigint try => 'GMP';\n    is_deeply(\n              [sum_of_two_squares_solutions(Math::GMPz->new(\"11392163240756069707031250\"))],\n              [[39309472125,   3374998963875],\n               [216763660575,  3368260197225],\n               [477329304375,  3341305130625],\n               [729359177085,  3295481517405],\n               [735019741071,  3294223614297],\n               [907262616645,  3251005657515],\n               [982736803125,  3228992353125],\n               [1151205969375, 3172835964375],\n               [1224793301193, 3145162095999],\n               [1393801568775, 3074000720175],\n               [1622919634875, 2959441687125],\n               [1847545189875, 2824666354125],\n               [1993551800625, 2723584854375],\n               [2056446956025, 2676413487825],\n               [2194367046795, 2564549961435],\n               [2198769707673, 2560776252111],\n               [2386646521875, 2386646521875]\n              ]\n             );\n\n    is_deeply([sum_of_two_squares_solutions(2**128 + 1)], [[1, 18446744073709551616], [8479443857936402504, 16382350221535464479]]);\n\n    is_deeply(\n              [sum_of_two_squares_solutions(13**18 * 5**7)],\n              [[75291211970,   2963091274585],\n               [100083884615,  2962357487570],\n               [124869548830,  2961416259815],\n               [149646468985,  2960267657230],\n               [154416779750,  2960022656375],\n               [179181003625,  2958626849750],\n               [203932680250,  2957023863625],\n               [228670076375,  2955213810250],\n               [253391459750,  2953196816375],\n               [258150241063,  2952784638466],\n               [282850264814,  2950521038023],\n               [307530481817,  2948050825694],\n               [332189163826,  2945374174457],\n               [356824584103,  2942491271746],\n               [481345955350,  2924702504425],\n               [505803171575,  2920572173350],\n               [530224968650,  2916237327575],\n               [554609636425,  2911698270650],\n               [578955467350,  2906955320425],\n               [583639307225,  2906018552450],\n               [607936593550,  2901032879225],\n               [632191308775,  2895844059550],\n               [656401754450,  2890452456775],\n               [680566235225,  2884858448450],\n               [802350873038,  2853386013959],\n               [826200069721,  2846571993278],\n               [849991411282,  2839558639801],\n               [873723231719,  2832346444642],\n               [897393869198,  2824935912839],\n               [901945120375,  2823486084250],\n               [925540625750,  2815839700375],\n               [949071319625,  2807996135750],\n               [972535554250,  2799955939625],\n               [977046452345,  2798385051790],\n               [1000429281410, 2790111094745],\n               [1023742054855, 2781641758610],\n               [1046983140190, 2772977636455],\n               [1070150909945, 2764119334990],\n               [1186462080890, 2716226499895],\n               [1209150070505, 2706203018090],\n               [1231753388710, 2695990032905],\n               [1254270452695, 2685588259510],\n               [1276699685690, 2674998426295],\n               [1281008818375, 2672937536750],\n               [1303331253250, 2662124398375],\n               [1325562421625, 2651124843250],\n               [1347700766750, 2639939641625],\n               [1369744738375, 2628569576750],\n               [1373978929622, 2626358804329],\n               [1395908335991, 2614769317862],\n               [1417739993098, 2602996730711],\n               [1439472372169, 2591041867258],\n               [1461103951382, 2578905564649],\n               [1569204922025, 2514592328950],\n               [1590192225050, 2501373094025],\n               [1611068173975, 2487978699050],\n               [1631831306950, 2474410081975],\n               [1652480170025, 2460668192950],\n               [1656443419150, 2458002007175],\n               [1676954116825, 2444054737150],\n               [1697347384850, 2429936320825],\n               [1717621795175, 2415647746850],\n               [1838087734327, 2325298292486],\n               [1857481600234, 2309835659287],\n               [1876745394953, 2294211278554],\n               [1895877769526, 2278426244393],\n               [1899547017625, 2275368057250],\n               [1918520912750, 2259392877625],\n               [1937360462375, 2243259482750],\n               [1956064347250, 2226969002375],\n               [1974631257625, 2210522577250],\n               [1978190975930, 2207337566135],\n               [1996592834665, 2190706671530],\n               [2014854880870, 2173922371465],\n               [2032975835735, 2156985841270],\n               [2050954430330, 2139898266935]\n              ]\n             );\n};\n\nmy @nums = (@ARGV ? (map { Math::GMPz->new($_) } @ARGV) : (map { int rand(~0) } 1 .. 20));\n\nforeach my $n (@nums) {\n    (my @solutions = sum_of_two_squares_solutions($n)) || next;\n\n    say \"$n = \" . join(' = ', map { \"$_->[0]^2 + $_->[1]^2\" } @solutions);\n\n    # Verify solutions\n    foreach my $solution (@solutions) {\n        if ($n != $solution->[0]**2 + $solution->[1]**2) {\n            die \"error for $n: (@$solution)\\n\";\n        }\n    }\n}\n"
  },
  {
    "path": "Math/sum_of_two_squares_multiple_solutions.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 24 October 2017\n# https://github.com/trizen\n\n# Algorithm for finding solutions to the equation a^2 + b^2 = n,\n# for any given positive integer `n` for which such a solution exists.\n\n# The number of returned solutions is at least as many as\n# the number of unique prime factors p = 1 (mod 4) in `n`.\n\n# For numbers with primes powers p^k = 1 (mod 4), for k > 1, not all the possible solutions are returned.\n# For example, when n = 9925 = 5^2 * 397, only the following two solutions are returned: [58, 81], [33, 94].\n# The missing solution for 9925, is: [30, 95].\n\n# This algorithm is efficient when the factorization of `n` is known.\n\n# See also:\n#   https://oeis.org/A001481\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\nuse ntheory qw(sqrtmod factor_exp chinese forsetproduct);\n\nsub sum_of_two_squares_solution ($n) {\n\n    $n == 0 and return [0, 0];\n\n    my $prod1 = 1;\n    my $prod2 = 1;\n\n    my @prime_powers;\n\n    foreach my $f (factor_exp($n)) {\n        if ($f->[0] % 4 == 3) {            # p = 3 (mod 4)\n            $f->[1] % 2 == 0 or return;    # power must be even\n            $prod2 *= $f->[0]**($f->[1] >> 1);\n        }\n        elsif ($f->[0] == 2) {             # p = 2\n            if ($f->[1] % 2 == 0) {        # power is even\n                $prod2 *= $f->[0]**($f->[1] >> 1);\n            }\n            else {                         # power is odd\n                $prod1 *= $f->[0];\n                $prod2 *= $f->[0]**(($f->[1] - 1) >> 1);\n                push @prime_powers, $f->[0];\n            }\n        }\n        else {                             # p = 1 (mod 4)\n            $prod1 *= $f->[0]**$f->[1];\n            push @prime_powers, $f->[0]**$f->[1];\n        }\n    }\n\n    $prod1 == 1 and return [$prod2, 0];\n    $prod1 == 2 and return [$prod2, $prod2];\n\n    my %table;\n    foreach my $pp (@prime_powers) {\n        my $r = sqrtmod($pp - 1, $pp);\n        push @{$table{$pp}}, [$r, $pp], [$pp - $r, $pp];\n    }\n\n    my @square_roots;\n\n    forsetproduct {\n        push @square_roots, chinese(@_);\n    } values %table;\n\n    my @solutions;\n    foreach my $r (@square_roots) {\n\n        my $s = $r;\n        my $q = $prod1;\n\n        while ($s * $s > $prod1) {\n            ($s, $q) = ($q % $s, $s);\n        }\n\n        push @solutions, [$prod2 * $s, $prod2 * ($q % $s)];\n    }\n\n    return sort { $a->[0] <=> $b->[0] } do {\n        my %seen;\n        grep { !$seen{$_->[0]}++ } map {\n            [sort { $a <=> $b } @$_]\n        } @solutions;\n    };\n}\n\nforeach my $n (1 .. 1e5) {\n    (my @solutions = sum_of_two_squares_solution($n)) || next;\n\n    say \"$n = \" . join(' = ', map { \"$_->[0]^2 + $_->[1]^2\" } @solutions);\n\n    # Verify solutions\n    foreach my $solution (@solutions) {\n        if ($n != $solution->[0]**2 + $solution->[1]**2) {\n            die \"error for $n: (@$solution)\\n\";\n        }\n    }\n}\n\n__END__\n999826 = 99^2 + 995^2 = 315^2 + 949^2 = 699^2 + 715^2 = 525^2 + 851^2\n999828 = 318^2 + 948^2\n999844 = 410^2 + 912^2 = 312^2 + 950^2\n999848 = 62^2 + 998^2\n999850 = 43^2 + 999^2 = 321^2 + 947^2\n999853 = 387^2 + 922^2\n999857 = 544^2 + 839^2 = 401^2 + 916^2\n999860 = 698^2 + 716^2 = 154^2 + 988^2\n999869 = 262^2 + 965^2 = 613^2 + 790^2\n999881 = 484^2 + 875^2 = 341^2 + 940^2\n999882 = 309^2 + 951^2 = 651^2 + 759^2\n999890 = 421^2 + 907^2 = 473^2 + 881^2\n999892 = 324^2 + 946^2\n999898 = 697^2 + 717^2 = 213^2 + 977^2\n999909 = 678^2 + 735^2 = 222^2 + 975^2\n999914 = 667^2 + 745^2\n999917 = 109^2 + 994^2\n999937 = 89^2 + 996^2 = 44^2 + 999^2\n999938 = 77^2 + 997^2\n999940 = 696^2 + 718^2 = 126^2 + 992^2 = 448^2 + 894^2 = 178^2 + 984^2\n999941 = 446^2 + 895^2 = 370^2 + 929^2\n999944 = 638^2 + 770^2\n999946 = 585^2 + 811^2\n999949 = 243^2 + 970^2 = 450^2 + 893^2\n999952 = 444^2 + 896^2\n999953 = 568^2 + 823^2\n999954 = 375^2 + 927^2 = 327^2 + 945^2\n999956 = 500^2 + 866^2\n999961 = 644^2 + 765^2\n999962 = 541^2 + 841^2 = 239^2 + 971^2\n999968 = 452^2 + 892^2\n999970 = 627^2 + 779^2 = 247^2 + 969^2\n999973 = 658^2 + 753^2 = 118^2 + 993^2 = 63^2 + 998^2 = 622^2 + 783^2\n999981 = 141^2 + 990^2\n999986 = 365^2 + 931^2 = 695^2 + 719^2\n999997 = 194^2 + 981^2 = 454^2 + 891^2\n1000000 = 352^2 + 936^2\n"
  },
  {
    "path": "Math/sum_of_two_squares_solution.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 24 October 2017\n# https://github.com/trizen\n\n# Algorithm for finding a solution to the equation a^2 + b^2 = n,\n# for any given positive integer `n` for which such a solution exists.\n\n# This algorithm is efficient when the factorization of `n` is known.\n\n# See also:\n#   https://oeis.org/A001481\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(sqrtmod factor_exp);\nuse experimental qw(signatures);\n\nsub sum_of_two_squares_solution ($n) {\n\n    $n == 0 and return (0, 0);\n\n    my $prod1 = 1;\n    my $prod2 = 1;\n\n    foreach my $f (factor_exp($n)) {\n        if ($f->[0] % 4 == 3) {            # p = 3 (mod 4)\n            $f->[1] % 2 == 0 or return;    # power must be even\n            $prod2 *= $f->[0]**($f->[1] >> 1);\n        }\n        elsif ($f->[0] == 2) {             # p = 2\n            if ($f->[1] % 2 == 0) {        # power is even\n                $prod2 *= $f->[0]**($f->[1] >> 1);\n            }\n            else {                         # power is odd\n                $prod1 *= $f->[0];\n                $prod2 *= $f->[0]**(($f->[1] - 1) >> 1);\n            }\n        }\n        else {                             # p = 1 (mod 4)\n            $prod1 *= $f->[0]**$f->[1];\n        }\n    }\n\n    $prod1 == 1 and return ($prod2, 0);\n    $prod1 == 2 and return ($prod2, $prod2);\n\n    my $s = sqrtmod($prod1 - 1, $prod1) || return;\n    my $q = $prod1;\n\n    while ($s * $s > $prod1) {\n        ($s, $q) = ($q % $s, $s);\n    }\n\n    return ($prod2 * $s, $prod2 * ($q % $s));\n}\n\nforeach my $n (0 .. 1e5) {\n    my ($x, $y, $z) = sum_of_two_squares_solution($n);\n\n    if (defined($x) and defined($y)) {\n        say \"f($n) = $x^2 + $y^2\";\n\n        if ($n != $x**2 + $y**2) {\n            warn \"error for $n\\n\";\n        }\n    }\n}\n\n__END__\nf(999909) = 735^2 + 678^2\nf(999914) = 745^2 + 667^2\nf(999917) = 994^2 + 109^2\nf(999937) = 996^2 + 89^2\nf(999938) = 997^2 + 77^2\nf(999940) = 718^2 + 696^2\nf(999941) = 895^2 + 446^2\nf(999944) = 770^2 + 638^2\nf(999946) = 811^2 + 585^2\nf(999949) = 970^2 + 243^2\nf(999952) = 896^2 + 444^2\nf(999953) = 823^2 + 568^2\nf(999954) = 927^2 + 375^2\nf(999956) = 866^2 + 500^2\nf(999961) = 765^2 + 644^2\nf(999962) = 841^2 + 541^2\nf(999968) = 892^2 + 452^2\nf(999970) = 779^2 + 627^2\nf(999973) = 753^2 + 658^2\nf(999981) = 990^2 + 141^2\nf(999986) = 931^2 + 365^2\nf(999997) = 981^2 + 194^2\nf(1000000) = 936^2 + 352^2\n"
  },
  {
    "path": "Math/sum_remainders.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 10 March 2021\n# https://github.com/trizen\n\n# Let's consider the following function:\n#   a(n,v) = Sum_{k=1..n} (v mod k)\n\n# The goal is to compute a(n,v) in sublinear time with respect to v.\n\n# Formula:\n#   a(n,v) = n*v - A024916(v) + Sum_{k=n+1..v} k*floor(v/k).\n\n# Formula derived from:\n#   a(n,v) = Sum_{k=1..n} (v - k*floor(v/k))\n#          = n*v - Sum_{k=1..n} k*floor(v/k)\n#          = n*v - Sum_{k=1..v} k*floor(v/k) + Sum_{k=n+1..v} k*floor(v/k)\n\n# Related problem:\n#   Is there a sublinear formula for computing: Sum_{1<=k<=n, gcd(k,n)=1} k*floor(n/k) ?\n\n# See also:\n#   https://oeis.org/A099726 -- Sum of remainders of the n-th prime mod k, for k = 1,2,3,...,n.\n#   https://oeis.org/A340976 -- Sum_{1 < k < n} sigma(n) mod k, where sigma = A000203.\n#   https://oeis.org/A340180 -- a(n) = Sum_{x in C(n)} (sigma(n) mod x), where C(n) is the set of numbers < n coprime to n, and sigma = A000203.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse ntheory qw(:all);\nuse experimental qw(signatures);\n\nsub triangular ($n) {    # Sum_{k=1..n} k = n-th triangular number\n    divint(mulint($n, addint($n, 1)), 2);\n}\n\nsub sum_of_sigma ($n) {    # A024916(n) = Sum_{k=1..n} sigma(k) = Sum_{k=1..n} k*floor(n/k)\n\n    my $T = 0;\n    my $s = sqrtint($n);\n\n    foreach my $k (1 .. $s) {\n        my $t = divint($n, $k);\n        $T = vecsum($T, triangular($t), mulint($k, $t));\n    }\n\n    subint($T, mulint(triangular($s), $s));\n}\n\nsub g ($a, $b) {    # g(a,b) = Sum_{k=a..b} k*floor(b/k)\n\n    my $T = 0;\n\n    while ($a <= $b) {\n\n        my $t = divint($b, $a);\n        my $u = divint($b, $t);\n\n        $T = addint($T, mulint($t, subint(triangular($u), triangular(subint($a, 1)))));\n        $a = addint($u, 1);\n    }\n\n    return $T;\n}\n\nsub sum_remainders ($n, $v) {    # sub-linear formula\n    addint(subint(mulint($n, $v), sum_of_sigma($v)), g(addint($n, 1), $v));\n}\n\nsay sprintf \"[%s]\", join(', ', map { sum_remainders($_,     nth_prime($_)) } 1 .. 20);      #=> A099726\nsay sprintf \"[%s]\", join(', ', map { sum_remainders($_ - 1, divisor_sum($_)) } 1 .. 20);    #=> A340976\n\nforeach my $k (1 .. 8) {\n    say(\"A099726(10^$k) = \", sum_remainders(powint(10, $k), nth_prime(powint(10, $k))));\n}\n\n__END__\nA099726(10^1) = 30\nA099726(10^2) = 2443\nA099726(10^3) = 248372\nA099726(10^4) = 25372801\nA099726(10^5) = 2437160078\nA099726(10^6) = 252670261459\nA099726(10^7) = 24690625139657\nA099726(10^8) = 2516604108737704\n"
  },
  {
    "path": "Math/super_pandigital_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 20 August 2017\n# https://github.com/trizen\n\n# Generate the smallest super-pandigital numbers that are simultaneously pandigital in all bases from 2 to n inclusively.\n\n# Brute-force solution.\n\n# See also:\n#   # https://projecteuler.net/problem=571\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse List::Util qw(uniq all min);\nuse ntheory qw(todigits fromdigits);\nuse Algorithm::Combinatorics qw(variations);\n\nmy $base  = shift(@ARGV) // 10;    # pandigital in all bases 2..$base\nmy $first = 10;                    # generate first n numbers\n\nmy @digits = (1, 0, 2 .. $base - 1);\nmy @bases  = reverse(2 .. $base - 1);\n\nmy $sum  = 0;\nmy $iter = variations(\\@digits, $base);\n\nwhile (defined(my $t = $iter->next)) {\n\n    if ($t->[0]) {\n        my $d = fromdigits($t, $base);\n\n        if (all { uniq(todigits($d, $_)) == $_ } @bases) {\n            say \"Found: $d\";\n            $sum += $d;\n            last if --$first == 0;\n        }\n    }\n}\n\nsay \"Sum: $sum\";\n\n__END__\n\nFirst 10 super-pandigital numbers in bases 2 up to 10:\n\n1093265784\n1367508924\n1432598706\n1624573890\n1802964753\n2381059764\n2409758631\n2578693140\n2814609357\n2814759360\n\nSum: 20319792309\n"
  },
  {
    "path": "Math/tangent_numbers.pl",
    "content": "#!/usr/bin/perl\n\n# Algorithm for computing the tangent numbers:\n#\n#   1, 2, 16, 272, 7936, 353792, 22368256, 1903757312, 209865342976, 29088885112832, ...\n#\n\n# Algorithm presented in the book:\n#\n#   Modern Computer Arithmetic\n#           - by Richard P. Brent and Paul Zimmermann\n#\n\n# See also:\n#   https://oeis.org/A000182\n#   https://mathworld.wolfram.com/TangentNumber.html\n#   https://en.wikipedia.org/wiki/Alternating_permutation\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\n\nsub tangent_numbers {\n    my ($n) = @_;\n\n    my @T = (Math::GMPz::Rmpz_init_set_ui(1));\n\n    foreach my $k (1 .. $n - 1) {\n        Math::GMPz::Rmpz_mul_ui($T[$k] = Math::GMPz::Rmpz_init(), $T[$k - 1], $k);\n    }\n\n    foreach my $k (1 .. $n - 1) {\n        foreach my $j ($k .. $n - 1) {\n            Math::GMPz::Rmpz_mul_ui($T[$j], $T[$j], $j - $k + 2);\n            Math::GMPz::Rmpz_addmul_ui($T[$j], $T[$j - 1], $j - $k);\n\n        }\n    }\n\n    return @T;\n}\n\nsay join(', ', tangent_numbers(10));\n"
  },
  {
    "path": "Math/trial_division_fast.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 31 January 2022\n# https://github.com/trizen\n\n# Fast adaptive trial-division algorithm.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::GMPz;\nuse Time::HiRes qw(gettimeofday tv_interval);\nuse Math::Prime::Util::GMP qw(:all);\n\nuse experimental qw(signatures);\n\nsub fast_trial_factor ($n, $L = 1e4, $R = 1e6) {\n\n    $n = Math::GMPz->new(\"$n\");\n\n    my @P = sieve_primes(2, $L);\n\n    my $g = Math::GMPz::Rmpz_init();\n    my $t = Math::GMPz::Rmpz_init();\n\n    my @factors;\n\n    while (1) {\n\n        # say \"L = $L with $#P\";\n\n        Math::GMPz::Rmpz_set_str($g, vecprod(@P), 10);\n        Math::GMPz::Rmpz_gcd($g, $g, $n);\n\n        # Early stop when n seems to no longer have small factors\n        if (Math::GMPz::Rmpz_cmp_ui($g, 1) == 0) {\n            last;\n        }\n\n        # Factorize n over primes in P\n        foreach my $p (@P) {\n            if (Math::GMPz::Rmpz_divisible_ui_p($g, $p)) {\n\n                Math::GMPz::Rmpz_set_ui($t, $p);\n                my $valuation = Math::GMPz::Rmpz_remove($n, $n, $t);\n                push @factors, ($p) x $valuation;\n\n                # Stop the loop early when no more primes divide `g` (optional)\n                Math::GMPz::Rmpz_divexact_ui($g, $g, $p);\n                last if (Math::GMPz::Rmpz_cmp_ui($g, 1) == 0);\n            }\n        }\n\n        # Early stop when n has been fully factored or the trial range has been exhausted\n        if ($L >= $R or Math::GMPz::Rmpz_cmp_ui($n, 1) == 0) {\n            last;\n        }\n\n        @P = sieve_primes($L + 1, $L << 1);\n        $L <<= 1;\n    }\n\n    return (\\@factors, $n);\n}\n\nmy $n = consecutive_integer_lcm(138861);\n\n# $n = vecprod($n, Math::GMPz->new(2)**128 + 1);\n\nsay \"Length of n = \", length($n);\n\nmy $t0 = [gettimeofday];\nmy ($f, $r) = fast_trial_factor($n);\nmy $elapsed = tv_interval($t0, [gettimeofday]);\n\nsay \"remainder = $r\";\nsay \"bigomega(n) = \", scalar(@$f);\nsay \"Factorization took $elapsed seconds.\";\n\n__END__\nLength of n = 60336\nremainder = 1\nbigomega(n) = 13034\nFactorization took 0.490573 seconds.\n"
  },
  {
    "path": "Math/triangle_hyperoperation.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 16 October 2016\n# Website: https://github.com/trizen\n\n# Efficient implementation of the triangle hyperoperation, modulo some n.\n\n# For definition, see:\n#   https://www.youtube.com/watch?v=sW_IkMQEAwo\n\n# See also:\n#   https://www.youtube.com/watch?v=9DeOnCKfSuY\n\nuse strict;\nuse integer;\nuse warnings;\n\nuse ntheory qw(powmod forprimes);\n\nsub triangle {\n    my ($n, $k, $mod) = @_;\n    return $n if $k == 1;\n    powmod($n, triangle($n, $k - 1, $mod), $mod);\n}\n\n# let z = triangle(10, 10) + 23\n# Question: what are the prime factors of z?\n\nforprimes {\n    my $r = (triangle(10, 10, ${_}) + 23) % ${_};\n    print \"$_ divides z\\n\" if $r == 0;\n} 1e5;\n"
  },
  {
    "path": "Math/triangle_interior_angles.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 22 January 2018\n# https://github.com/trizen\n\n# Formula for finding the interior angles of a triangle, given its side lengths.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(acos rad2deg);\n\nmy $x = 3;\nmy $y = 4;\nmy $z = 5;\n\nsay rad2deg(acos(($y**2 + $z**2 - $x**2) / (2 * $y * $z)));     # 36.869...\nsay rad2deg(acos(($x**2 - $y**2 + $z**2) / (2 * $x * $z)));     # 53.130...\nsay rad2deg(acos(($x**2 + $y**2 - $z**2) / (2 * $x * $y)));     # 90\n"
  },
  {
    "path": "Math/tribonacci_primality_test.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 18 May 2019\n# https://github.com/trizen\n\n# A new primality test, using a Tribonacci-like sequence.\n\n# Sequence definition:\n#   T(0) = 0\n#   T(1) = 0\n#   T(2) = 9\n#   T(n) = T(n-1) + 3*T(n-2) + 9*T(n-3)\n\n# Closed form:\n#   T(n) = (-9 sqrt(2) (-1 + i sqrt(2))^n + 2 (sqrt(2) + 4 i)×3^n + (7 sqrt(2) - 8 i) (-1 - i sqrt(2))^n)/(4 (sqrt(2) + 4 i))\n\n# The sequence starts as:\n#   0, 0, 9, 9, 36, 144, 333, 1089, 3384, 9648, 29601, 89001, 264636, 798048, ...\n\n# When p is a prime > 5 congruent to {1,3} mod 8, then T(p) == 0 (mod p).\n# When p is a prime > 5 congruent to {5,7} mod 8, then T(p) == 4 (mod p).\n\n# Counter-examples:\n#   for n == 1 (mod 8): 88561,107185,162401,221761,226801,334153,410041,665281,825265,1569457,1615681,2727649, ...\n#   for n == 3 (mod 8): 80375707,154287451,267559627,326266051,478614067,573183451,643767931,2433943891,4297753027, ....\n\n# See also:\n#   https://trizenx.blogspot.com/2020/01/primality-testing-algorithms.html\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(:overload);\nuse Math::MatrixLUP;\n\nuse ntheory qw(is_prime);\nuse experimental qw(signatures);\n\nmy $A = Math::MatrixLUP->new([[0, 3, 0], [0, 0, 3], [1, 1, 1]]);\nmy $B = Math::MatrixLUP->new([[4, 2, 3], [1, 5, 3], [1, 2, 6]]);\nmy $I = Math::MatrixLUP->new([[1, 0, 0], [0, 1, 0], [0, 0, 1]]);\n\nsub is_tribonacci_prime ($n) {\n\n    my $r = $n % 8;\n\n    if ($r == 1 or $r == 3) {\n        return ($A->powmod($n - 1, $n) == $I);\n    }\n\n    if ($r == 5 or $r == 7) {\n        return ($A->powmod($n + 1, $n) == $B);\n    }\n\n    return;\n}\n\nlocal $| = 1;\nforeach my $n (7 .. 1e3) {\n    if (is_tribonacci_prime($n)) {\n        if (not is_prime($n)) {\n            say \"\\nCounter-example: $n\\n\";\n        }\n        print($n, \", \");\n    }\n    elsif (is_prime($n)) {\n        say \"\\nMissed prime: $n\\n\";\n    }\n}\n"
  },
  {
    "path": "Math/trip2mars.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# License: GPLv3\n# Date: 15 October 2013\n# https://trizenx.blogspot.com\n\n# This program solves the \"Trip to Mars\" problem\n# See: https://www.youtube.com/watch?v=k-zrgRv9tFU\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nmy %max = (\n           hours  => 0,\n           games  => 0,\n           movies => 0,\n          );\n\nforeach my $x (0 .. 200) {\n    foreach my $y (0 .. 200 - $x) {\n\n        next if 8 * $x + 3 * $y > 1200;\n        next if 0.2 * $x + 0.8 * $y > 130;\n\n        my $hours = 4 * $x + 2 * $y;\n\n        if ($hours > $max{hours}) {\n            $max{hours}  = $hours;\n            $max{games}  = $x;\n            $max{movies} = $y;\n        }\n    }\n}\n\nsay \"To maximize the time on breaks, you need to buy $max{games} games and $max{movies} movies.\";\n"
  },
  {
    "path": "Math/unique_permutations.pl",
    "content": "#!/usr/bin/perl\n\n# Generate only the unique permutations of a given array.\n\n# Optimized Unique Permutation DFS without explicit key tracking\n# Recursively branches unique factors only at each depth.\n\nuse 5.036;\n\nsub unique_permutations($array, $callback) {\n    sub ($items, $current_perm) {\n\n        if (!@$items) {\n            $callback->($current_perm);\n            return;\n        }\n\n        my %level_seen;\n        for my $i (0 .. $#$items) {\n            my $item = $items->[$i];\n\n            # Skip iterations for duplicate elements in the same level\n            next if $level_seen{$item}++;\n\n            my @new_items = @$items;\n            splice(@new_items, $i, 1);\n\n            my @new_perm = (@$current_perm, $item);\n            __SUB__->(\\@new_items, \\@new_perm);\n        }\n    }->($array, []);\n}\n\nunique_permutations(\n    [3, 2, 2, 3],\n    sub ($perm) {\n        say \"(@$perm)\";\n    }\n);\n\n__END__\n(3 2 2 3)\n(3 2 3 2)\n(3 3 2 2)\n(2 3 2 3)\n(2 3 3 2)\n(2 2 3 3)\n"
  },
  {
    "path": "Math/unitary_divisors.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 01 July 2018\n# https://github.com/trizen\n\n# A simple algorithm for generating the unitary divisors of a given number.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Unitary_divisor\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(forcomb factor_exp vecprod powint);\n\n# This algorithm nicely illustrates the identity:\n#\n#   2^n = Sum_{k=0..n} binomial(n, k)\n#\n# which is the number of divisors of a squarefree number that is the product of `n` primes.\n\nsub udivisors {\n    my ($n) = @_;\n\n    my @pp  = map { powint($_->[0], $_->[1]) } factor_exp($n);\n    my $len = scalar(@pp);\n\n    my @d;\n    foreach my $k (0 .. $len) {\n        forcomb {\n            push @d, vecprod(@pp[@_]);\n        } $len, $k;\n    }\n\n    return sort { $a <=> $b } @d;\n}\n\nsay join(' ', udivisors(5040));\n"
  },
  {
    "path": "Math/unitary_divisors_fast.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 01 July 2018\n# https://github.com/trizen\n\n# A simple algorithm for generating the unitary divisors of a given number.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Unitary_divisor\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(factor_exp powint mulint);\n\nsub udivisors {\n    my ($n) = @_;\n\n    my @d  = (1);\n    my @pp = map { powint($_->[0], $_->[1]) } factor_exp($n);\n\n    foreach my $p (@pp) {\n        push @d, map { mulint($_, $p) } @d;\n    }\n\n    return sort { $a <=> $b } @d;\n}\n\nsay join(' ', udivisors(5040));\n"
  },
  {
    "path": "Math/unitary_squarefree_divisors.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 27 June 2018\n# https://github.com/trizen\n\n# Generate the unitary squarefree divisors of a given number.\n\n# See also:\n#   https://oeis.org/A092261\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(factor_exp);\n\nsub unitary_squarefree_divisors {\n    my ($n) = @_;\n\n    my @d  = (1);\n    my @pp = map { $_->[0] } grep { $_->[1] == 1 } factor_exp($n);\n\n    foreach my $p (@pp) {\n        push @d, map { $_ * $p } @d;\n    }\n\n    return sort { $a <=> $b } @d;\n}\n\nforeach my $n (1 .. 30) {\n    my @d = unitary_squarefree_divisors($n);\n    say \"a($n) = [@d]\";\n}\n"
  },
  {
    "path": "Math/wilson_prime_formula.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 27 September 2014\n# Edit: 15 May 2021\n# https://github.com/trizen\n\n# See also:\n#   https://en.wikipedia.org/wiki/Wilson's_theorem\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse Math::AnyNum qw(factorial);\nuse experimental qw(signatures);\n\nsub is_wilson_prime($n) {\n    factorial($n-1) % $n == $n-1;\n}\n\nfor my $n (2..100) {\n    if (is_wilson_prime($n)) {\n        print($n, \", \");\n    }\n}\n"
  },
  {
    "path": "Math/yahtzee.pl",
    "content": "#!/usr/bin/perl\n\n# One-Roll Yahtzee Fever\n\n# https://www.youtube.com/watch?v=dXGhzY2p2ug\n\nmy (@list) = (0) x 5;\nmy $count = 0;\n\ndo {\n    foreach my $num (@list) {\n        $num = int(rand 6) + 1;\n    }\n    ++$count;\n} until ((grep { $_ == $list[0] } @list) == @list);\n\nprint \"Rolls: $count\\tNumber: $list[0]\\n\";\n"
  },
  {
    "path": "Math/zequals.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 21 February 2013\n# https://github.com/trizen\n\n# Zequals and estimations\n# https://www.youtube.com/watch?v=aOJOfh2_4PE\n\n# Example: 722 * 49 ~~ 700 * 50\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub round {    # doesn't work as you expect!\n    my ($num) = @_;\n\n    my $i = 10;\n    while ($i < $num) {\n        if ($num % $i >= $i / 2) {\n            $num += $i - $num % $i;\n        }\n        else {\n            $num -= $num % $i;\n        }\n        $i *= 10;\n    }\n\n    return $num;\n}\n\nsub round_right {    # this works as expected.\n    my ($num) = @_;\n\n    my $i    = 10**int(log($num) / log(10));\n    my $base = $i * int($num / $i);\n\n    if ($num - $base >= $i / 2) {\n        return $num + ($i - ($num - $base));\n    }\n    else {\n        return $num - ($num - $base);\n    }\n}\n\nsub zequal {\n    my ($x, $y) = @_;\n    return (round($x) * round($y));\n}\n\nsub zequal_right {\n    my ($x, $y) = @_;\n    return (round_right($x) * round_right($y));\n}\n\n{\n    my ($x, $y) = (shift || 345, shift || 342);\n\n    say \"Zequal simple ($x, $y) ~~ \", zequal($x, $y);\n    say \"Zequal right  ($x, $y) ~~ \", zequal_right($x, $y);\n    say \"Reality       ($x, $y) == \", $x * $y;\n}\n"
  },
  {
    "path": "Math/zeta_2n.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 06 September 2015\n# Website: https://github.com/trizen\n\n# Calculate zeta(2n) using a closed-form formula.\n# See: https://en.wikipedia.org/wiki/Riemann_zeta_function\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Memoize qw(memoize);\nuse Math::AnyNum qw(:overload pi);\n\nsub bernoulli_number {\n    my ($n) = @_;\n\n    return 0 if $n > 1 && $n % 2;    # Bn = 0 for all odd n > 1\n\n    my @A;\n    for my $m (0 .. $n) {\n        $A[$m] = 1 / ($m + 1);\n\n        for (my $j = $m ; $j > 0 ; $j--) {\n            $A[$j - 1] = $j * ($A[$j - 1] - $A[$j]);\n        }\n    }\n\n    return $A[0];                    # which is Bn\n}\n\nsub factorial {\n    $_[0] < 2 ? 1 : factorial($_[0] - 1) * $_[0];\n}\n\nmemoize('factorial');\n\nsub zeta_2n {\n    my ($n2) = 2 * $_[0];\n    ((-1)**($_[0] + 1) * 2**($n2 - 1) * pi**$n2 * bernoulli_number($n2)) / factorial($n2);\n}\n\nfor my $i (1 .. 10) {\n    say \"zeta(\", 2 * $i, \") = \", zeta_2n($i);\n}\n"
  },
  {
    "path": "Math/zeta_for_primes.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 22 September 2015\n# Website: https://github.com/trizen\n\n# Zeta-prime formula\n#   Sum of 1/P(n)^p\n# where P(n) is a prime number and p is a positive integer.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse ntheory qw(nth_prime);\n\nmy @sums;\nforeach my $i (1 .. 100000) {\n    foreach my $p (1 .. 10) {\n        $sums[$p - 1] += 1 / nth_prime($i)**$p;\n    }\n}\n\nforeach my $p (0 .. $#sums) {\n    printf(\"zp(%d) = %s\\n\", $p + 1, $sums[$p]);\n}\n\n__END__\n#\n## From i=1..1000000\n#\nzp(1) = 3.06821904805445\nzp(2) = 0.452247416351722\nzp(3) = 0.174762639299271\nzp(4) = 0.0769931397642436\nzp(5) = 0.035755017483924\nzp(6) = 0.0170700868506365\nzp(7) = 0.00828383285613359\nzp(8) = 0.00406140536651783\nzp(9) = 0.00200446757496245\nzp(10) = 0.00099360357443698\n"
  },
  {
    "path": "Math/zeta_function.pl",
    "content": "#!/usr/bin/perl\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub zeta {\n    my ($n) = @_;\n    my $sum = 0;\n\n    foreach my $i (1 .. 1000000) {\n        $sum += (1 / $i**$n);\n    }\n\n    $sum;\n}\n\nsay zeta(2);\n"
  },
  {
    "path": "Math/zeta_prime_count_approx.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 07 January 2016\n# Website: https://github.com/trizen\n\n# A basic approximation for the number of primes less than or equal with `n`\n# based on the zeta function. More precisely, on the value of ζ(2).\n\n# The formula is:\n#\n#   pi(2) = 1\n#   pi(n) = pi(n-1) + log(ζ(2)) / (log10(^n) + log(1 / (1 - n^(-2))))\n#\n# where log10(^n) is the common logarithm of the initial \"n\".\n\n# It's based on the fact that:\n#             ∞\n# log(ζ(s)) = Σ (π(n) - π(n-1)) * log(1 / (1 - n^(-s)))\n#            n=2\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nno warnings 'recursion';\nuse ntheory qw(prime_count);\n\nmy $lz = log(1.64493406684822643647241516664602518922);    # log(ζ(2))\n\nsub pi {\n    my ($n, $lb) = @_;\n\n    return 0 if $n <= 1;\n    return 1 if $n == 2;\n\n    pi($n - 1, $lb) + ($lz / ($lb + log(1 / (1 - $n**(-2)))));\n}\n\nfor (my $i = 10 ; $i <= 3000 ; $i += 100) {\n    printf(\"pi(%4d) =~ %4s   (actual: %4s)\\n\", $i, int(pi($i, log($i) / log(10))), prime_count($i));\n}\n\n__END__\npi(  10) =~    4   (actual:    4)\npi( 110) =~   27   (actual:   29)\npi( 210) =~   45   (actual:   46)\npi( 310) =~   62   (actual:   63)\npi( 410) =~   78   (actual:   80)\npi( 510) =~   94   (actual:   97)\npi( 610) =~  109   (actual:  111)\npi( 710) =~  124   (actual:  127)\npi( 810) =~  139   (actual:  140)\npi( 910) =~  153   (actual:  155)\npi(1010) =~  167   (actual:  169)\npi(1110) =~  182   (actual:  186)\npi(1210) =~  196   (actual:  197)\npi(1310) =~  209   (actual:  214)\npi(1410) =~  223   (actual:  223)\npi(1510) =~  237   (actual:  239)\npi(1610) =~  250   (actual:  254)\npi(1710) =~  263   (actual:  267)\npi(1810) =~  277   (actual:  279)\npi(1910) =~  290   (actual:  292)\npi(2010) =~  303   (actual:  304)\npi(2110) =~  316   (actual:  317)\npi(2210) =~  329   (actual:  329)\npi(2310) =~  342   (actual:  343)\npi(2410) =~  355   (actual:  357)\npi(2510) =~  368   (actual:  368)\npi(2610) =~  380   (actual:  379)\npi(2710) =~  393   (actual:  394)\npi(2810) =~  406   (actual:  409)\npi(2910) =~  418   (actual:  421)\n"
  },
  {
    "path": "Media/wimp-viewer",
    "content": "#!/usr/bin/perl\n\n# List and play the most recent videos from: https://www.wimp.com/\n\n# Requires 'youtube-viewer' and 'mpv'\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse open ':std' => ':utf8';\n\nuse Encode qw(encode_utf8);\nuse XML::Fast qw(xml2hash);\nuse Term::ANSIColor qw(colored);\nuse Getopt::Std qw(getopts);\n\nmy $appname = 'wimp-viewer';\nmy $version = '0.33';\n\nmy $BASE_URL = 'https://www.wimp.com';\n\nrequire Term::ReadLine;\nmy $term = Term::ReadLine->new($appname);\n\nrequire WWW::Mechanize;\nmy $mech = WWW::Mechanize->new(\n              autocheck     => 1,\n              env_proxy     => 1,\n              show_progress => 0,\n              agent => 'Mozilla/5.0 (X11; Linux i686) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/36.0.1941.0 Safari/537.36',\n);\n\n$mech->default_header('Accept-Encoding' => scalar HTTP::Message::decodable());\n\nsub output_usage {\n    print <<\"HELP\";\nusage: $0 [options] [url]\n\noptions:\n        -f       : fullscreen mode\n        -r <i>   : play i of random videos and exit\n\n        -v       : print the version number and exit\n        -h       : print this help message and exit\nHELP\n}\n\nsub output_version {\n    say \"$appname $version\";\n}\n\nmy %opt;\nif (@ARGV) {\n    getopts('r:fvh', \\%opt);\n}\n\nif ($opt{h}) {\n    output_usage();\n    exit 0;\n}\n\nif ($opt{v}) {\n    output_version();\n    exit 0;\n}\n\nif (exists $opt{r}) {\n\n    if (defined($opt{r}) and $opt{r} > 0) {\n        for my $i (1 .. $opt{r}) {\n            play_random_video();\n        }\n    }\n    else {\n        die \"error: option '-r' requires a positive integer!\\n\";\n    }\n\n    exit;\n}\n\n# Play the command-line URIs\nforeach my $url (@ARGV) {\n    play($url);\n    exit;\n}\n\nsub play {\n    my ($url) = @_;\n\n    my $resp    = $mech->get($url);\n    my $content = $resp->decoded_content // $resp->content;\n\n    my $real_url = $mech->uri;\n\n    if (   $content =~ m{\\byoutube\\.com/watch\\?v=([\\w-]{11})\"}\n        or $content =~ m{<div data-autoplay='1' data-start='0' data-id='([\\w-]{11})'}\n        or $content =~ m{src=\"https://www.youtube.com/embed/([\\w-]{11})}) {\n        system 'youtube-viewer', \"--no-interactive\", \"--id=$1\", ($opt{f} ? '-fs' : ());\n    }\n    elsif (   $content =~ /\"file\"\\h*,\\h*\"(.*?)\"/\n           or $content =~ m{source type=\"video/mp4\" src=\"(https://.*?)\"}) {\n        system('mpv', ($opt{f} ? '--fullscreen' : ()), $1);\n    }\n    else {\n        warn \"error: can't find any streaming URL for: $real_url\\n\";\n        return;\n    }\n\n    return 1;\n}\n\nmy @results;\n\nforeach my $url (\"$BASE_URL/feed/?hot=1\", \"$BASE_URL/feed/\") {\n    my $hash_xml = xml2hash(encode_utf8($mech->get($url)->decoded_content));\n    push @results, @{$hash_xml->{rss}{channel}{item}};\n}\n\nsub play_picked_videos {\n    my (@list) = @_;\n\n    $#list >= 0 or return;\n    foreach my $num (@list) {\n        play($results[$num - 1]->{link});\n    }\n\n    return 1;\n}\n\nsub play_random_video {\n    play(\"$BASE_URL/random/\");\n    return 1;\n}\n\nsub parse_date {\n    my ($date) = @_;\n\n    # Turns \"Mon, 06 Feb 2012 00:00:00 -0600\" into \"Feb 06\"\n    if ($date =~ /^\\S+ (\\d+) (\\S+)/) {\n        return \"$2 $1\";\n    }\n\n    return $date // '';\n}\n\n{\n    print \"\\n\";\n    my $num = 0;\n    foreach my $video (@results) {\n        $video->{title} =~ s/\\s*\\[VIDEO\\]//;\n        printf \"%s. %s [%s]\\n\", colored(sprintf(\"%2d\", ++$num), 'bold'), $video->{title}, parse_date($video->{pubDate});\n    }\n\n    {\n        my $line = $term->readline(colored(\"\\n=>> Insert a number ('?' for help)\", 'bold') . \"\\n> \");\n        if ($line eq 'help' or $line eq '?') {\n            print \"\\n\", <<'STDIN_HELP';\ni               : play the corresponding video\nall             : play all the video results\n3-8, 3..8       : same as 3 4 5 6 7 8\n/my?[regex]*$/  : play videos matched by a regex (/i)\nq, quit, exit   : exit application\nSTDIN_HELP\n            redo;\n        }\n        elsif ($line =~ /^(?:q|quit|exit)\\z/) {\n            exit 0;\n        }\n        elsif ($line eq 'all') {\n            play_picked_videos(1 .. @results);\n        }\n        elsif ($line =~ m{^/(.*?)/\\h*$}) {\n            my $match = eval { qr/$1/i };\n\n            if ($@) {\n                warn \"\\nError in regex: $@\\n\";\n                redo;\n            }\n\n            play_picked_videos(grep { $results[$_ - 1]->{'title'} =~ /$match/ } 1 .. @results) || do {\n                warn \"\\n(X_X) No video matched by the regex: /$match/\\n\";\n                redo;\n            };\n        }\n\n        elsif ($line =~ /\\d/ and not $line =~ /(?>\\s|^)[^\\d-]/) {\n            $line =~ s/(\\d+)(?>-|\\.\\.)(\\d+)/join q{ }, $1 .. $2;/eg;    # '2..5' or '2-5' to '2 3 4 5'\n            play_picked_videos(grep { $_ > 0 and $_ <= @results if /^\\d+$/ } split(/[\\s[:punct:]]+/, $line));\n        }\n\n        elsif ($line =~ /^(?:r|random)\\z/) {\n            play_random_video();\n        }\n\n        elsif ($line =~ m{^https?://.}) {\n            play($_);\n        }\n    }\n    redo;\n}\n"
  },
  {
    "path": "Microphone/Alsa/raw_from_microphone.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 07 April 2014\n# Website: https://github.com/trizen\n\n# Read raw data from microphone (via ALSA/arecord)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Time::HiRes qw(sleep);\n\nuse constant {\n        HW_PARAMS_FILE => '/proc/asound/card0/pcm0c/sub0/hw_params',\n};\n\nopen(my $pipe_h, '-|', 'arecord', '-t', 'raw', '/dev/stdout') // exit $!;\nsleep 0.1;    # /proc can't be instant\n\nsub parse_config {\n    my ($file) = @_;\n\n    open my $fh, '<', $file or return;\n\n    my %table;\n    while (<$fh>) {\n        if (/^([^:]+):\\h*(.*\\S)/) {\n            $table{$1} = $2;\n        }\n    }\n\n    close $fh;\n    return \\%table;\n}\n\n# Read the hardware parameters file\nmy $hw_params = parse_config(HW_PARAMS_FILE) // die \"can't read config file: $!\";\n\nwhile (read($pipe_h, (my $buffer), $hw_params->{buffer_size})) {\n\n    # Here some interesting stuff needs to be written :)\n    #say length($buffer);\n\n    print \"\\n\";\n\n    my $i    = 0;\n    my @data = \"\";\n    foreach my $char (split(//, $buffer)) {\n\n        my $step = 20;             # a lower value means greater precision\n        my $ord  = ord($char);\n        my $mod  = $ord % $step;\n\n        if ($mod > ($step / 2)) {\n            $ord += ($step - $mod);\n        }\n        else {\n            $ord -= $mod;\n        }\n\n        if ($ord >= 127) {\n            $ord %= 127;\n        }\n\n        if ($ord <= 32) {\n            $ord += 32;\n        }\n\n        if ($ord == ord('-')) {    # '-' is for the background noise\n            if ($data[-1] ne '') {\n                ++$#data;\n                $data[-1] = '';\n            }\n            next;\n        }\n\n        $data[-1] .= chr $ord;\n    }\n\n    my @sen;\n    foreach my $seq (@data) {\n        my $len = length($seq);\n        if ((my $i = $len - ($len % 2)) > 0) {\n            push @sen, 'x' x $i;\n        }\n    }\n\n    print \"@sen\\n\";\n\n    ## Recursive self-recording\n    ## WARNING: code too awesome to be executed =D\n    #open my $fh, '>:raw', '/tmp/x';\n    #print $fh $buffer;\n    #close $fh;\n    #system 'aplay', '/tmp/x';\n}\n\n__END__\naccess: MMAP_INTERLEAVED\nformat: S32_LE\nsubformat: STD\nchannels: 2\nrate: 48000 (48000/1)\nperiod_size: 1024\nbuffer_size: 16384\n\n__DATA__\nxxxx xxxxxxx xxxx xxxxxx xx xxxxxx xxx xxxxxx xxx xxxxxx xxx xxxxxx xxxx xxxxx xxx xxxxx xxx xxxxx xxxxxx xxxxx xxxxxxxx xxxxxx xxxxxxx x xxxx xxxxxxxx xxxx xx xxxxxxxx xxx xxx xx xxxxxxxxxxx x x xx xx x xxxxxxx x x x xx x xxxxxxxx x x xx xxxxxxx x x xxx xxxxxx xxx xx x xxxxx xxx x xxxxxx x xx x xxxxxxx xx xxxxxxxx xx xxxx xx xxxxxx xx xxxxxx x xxxxx x xx\n16384\nxxxxx xxxxxx x xxxxxxxxx xxxxxxxx xxxxx xxxxx xxxxx xxxx xx xxxxxxxx xxxxxx x xxxxxxx xx x xxxxxx xxxx xxxxxx xxxxx xxxxxxxx xxx x xxxxxxxx ! xx xxxx x x x xx xxxxxx x xx xxxxxxxx xxx xx xxx x xxxxx xxx xxxxx xx x xx xxxxxx xxx x xxxxxx xxx x x xxxxxxxx x xxxxxxxxx xxxxx x xxxxxx xxxxx x xxxxxxxxxx x xxxxx xxxx\n16384\nxxxx xx xxxxxx xxxxxx xxxxxxxx xxxxxxxx xxxxxxx xxxxxx xxxxx xxx xxxxx xxxxx xxxxxxx xxxx xxxxx xxxxxxxxx xxx xxxx xxxxxxxx xxxx xxxx xxx xxx xxx xxx xxx x x xxxx x xxxx xxxxx xx xxx xx xx xxxxx x xxxx xxxxxxx x xxxxx xxxxxx xxxx xx\n16384\nxxxxx xxxxx x xxxxx xxx xxxxx x xxxx xxxxxx xxxxxx xxxxxx x xxxxx xxxx xxxxxx xxxxxx xxxx xxxxxxx xxx xxx x xxxx xxxx x x xxx x x x xx x xxxx xxxxx xxxxxx x xxxxxx xxxx xxxxx xxx xxx xxxxxx xx xxxxx xxxxxxxx xxxxxxx x x xxxxxxx xxxxxx xx xxxxxx x xxxxx x x xxxxxx xxxxxx xxxxx\n16384\nxxxxxxx xxxxxxx x xxxxx xxxxx x x xxxxxxx xxxxxxxxx xxxxxxx xxxxxxxxxxxx xxxxxxxxxx x xxxxxxxxxx xxxxxxx xxxxxxxxx xxxxxxxx x xxxxxx xxxxxxxxx xxxxxxx xxxxxxxx xxxxxxxxx xxxxxxxxxx x xxxxxxx xxxxxxxxxx xxxx x xxxxxx xx xxxxxxx xxx xxxxxx x xxxxxxxxx x x xxxxxxxxx xxxxxxxx x xxxxxxxx xxxxxx x x xxxx xxxxxx xxx xxxxxxxx xxxxxxxxxx x xx xxx x xx xxxxxxxx xxx xx xxx xxxxxxx x xx xx xxxxx xxx xx x xxxxxx x x xxxxxxxxxx xxxxxxxx xxxxxxxx xxxxxx xxxxxx xxx xxxxxxxxxxx\n16384\nxxx xxxxx xxxxxxx xxxxx xxxxxx xx xxxxxxxxx xxxx xxxxxxxxxx x x xxxxxx x xxxxxxxxxxxx x x xxxxxxxxxx xx xxxxxxxxxxx xxx x xxxxxxxx xxxxxxxx xxxxxxxx xxxxxxxxx xxxxx xxxxxxx xxxxxxxxxxx xxxxxxxx xxxxx xxxx xxxxxxxxx xxxxxxxx x xxxxxx x xxxxxxx xxxxxxx x x xxxxxxxx xxx xxxx xxxxxx xxxxxx x xxxxxx x xxxxxx x xxxxxx xxx xxxxxx x xxxxx xxx xxxxxxx xxxxxxx\n16384\nxxxxx xx xxxx xxxxxx xx xxxxxx x xxxxxx xxx xxxxx x xxxxx xxx xxxxxx xxxxx xxxxxx xxxxx xxx xxxxxxx x x xxxxxxx xxx x xxx xxxxxxx xxxx xxxxxxxxxxx xx xx xxxxxx x xxx xxxxx xxxx xxxxxxx xxx x xxxxxx xx xxxxx xxxxxxxx xx xxxxxx xx xxxxx x x xx xxx\n16384\nxxxxx xxxxxx xxxx xxxxxxx xxxx x xxxxxx xx xxxxx xxx xxxxxx xx xxxxx xx xxxxxx x xxxxx xxxxx xxxx xxx xxxx xxxxx x xx xxxxxxx xxxxxx xxx xxxxxx xxxx xxxxxxx xxx xxxxxxxxx xxx xx xxxxxxx xxx x xxxxxxx xxxx xx x xxxxxxx xxx x xx xxxxxxx xxxx x xxxxxx xxx xx xxxxxxx xxxx x x xxxxxxxx xxx xxxxxxx xxxx xxxxxxx x xxxxxx xxxx xxxxx\n16384\nxxxx xxxxx xxxxxxx xxxxxxx xxxxx xxxxx xxxx xxxx xxxxx xxxx xxxx xxxxx xxxxx xxxxxx xxxxxx xx x xxx xxxxxx x x xx xxxxxxxx x x x xxxxxxx xxx x xxxxxxxxx xx x x xxxxxx x xxxxxxx xxx x xxxxxx xx xx xxxxxxxx xxx x xxxxx x xxxxxxx xxxx xx xxxxx x xxxxxxxx x x xx\n16384\nxxxxxx x xx xxxxxx xxxxxx x xxxx xxxxx xxx xxxx xxx x xxxxxxx xxxxxx xxxxxxxx xxxxxxxxxxxx xxxxxx xxxxxx xxxxxxx xxxxxxx xxxxxxxxx xx xx xxxxxxxx xxxxxxx xxxxxxxx xxxxxxxx xxxxx xxxxxx x xx xxxxx xxxxxx x x xxxx x x xxxxx xx x xxxx xx xxxx xxx xxxxx xxx xxx\n16384\nxxx xx xxxxxx xx xxxxxx x xxxxxx xxxxx xxxxx x xxxxxx xxxxxxx xxxxxx xxxxx x x xxxxx x xxxx x xx x xx x xxxxxxx x xxxxxx x xx x xxxx xx x xx xxxxx xx x xxxx xx x xxxx x xx x xxxx xxx xxxxx xxxx xxxxxxx xxx xxxxxxxxx xxxxxxxxx xxxx\n16384\nxxxxx xxxxxxxx xxxx xxxxxx xxxxxxx xx xxxxx xxxx xxxx xxxxxxx xxxxx xxx xxxx xxxxxxx xxxxxxxx xxxx xxxxxx xx xxxxxxxxx xxxxxxx x xxxxxxxx x xx xxxxxxx x xxxxxxxxxxx xxxxxx xxxxxx x x xxxxxx xx xxxxxx xx xxxxx x xxxx xx xx xxxxx xxx xxxxxx xxxx xxxxx xxxx xx xxxx x\n16384\nx xxxxx xxxxxx x xxxxxxxx xxxx xxxxxx xx xxxx xxxxxx xxx xxxxx xxxx xx xx xxxx xxxxxxxxxx xxxx x x x xxxxxxxxxx xxxx x xxx xxxxx xxx xxxxxxx xx x xxxxxxx xx xxxxxxx xxxxxx x xxxxxxxx xxxxxxx xxxxxx xxxxxxx x xxxxx xxxxx xxx xxxxx xx xxxxx xx xxxx x xxxx xxxxx xxxxx xxxxxxxxxxx xxxxxxxxxxxxx xxxxx xxxxx\n"
  },
  {
    "path": "Microphone/Julius/julius_voice_control_concept.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 08 April 2014\n# Website: https://github.com/trizen\n\n# Voice control - take actions based on vocal commands\n# This script depends on the 'julius', which also needs\n# an acoustic model for the English language.\n# An open-source acoustic model can be downloaded from:\n#    https://www.voxforge.org/home/downloads\n\n# Configuration files: https://github.com/trizen/config-files/tree/master/.voxforge/julius\n\nuse utf8;\nuse 5.010;\nuse strict;\nuse warnings;\nuse List::Util qw(sum);\n\nno if $] >= 5.018, warnings => 'experimental';\n\nmy $config = \"$ENV{HOME}/.voxforge/julius/perl.jconf\";\nmy @julius = qw(julius -input mic);\n\nopen(my $pipe_h, '-|', @julius, '-C', $config) // exit $!;\n\nsub take_action {\n    my ($command) = @_;\n\n    given ($command) {\n        when ('<s> START MUSIC </s>') {\n            say \"Starting music...\";\n        }\n        when ('<s> START TERM </s>') {\n            say \"Opening the terminal...\";\n        }\n        default {\n            warn \"WARN: Invalid command `$command'!\\n\";\n        }\n    }\n}\n\nmy @buffer;\nwhile (<$pipe_h>) {\n\n    if (!/\\S/) {\n        my %conf;\n        foreach my $line (@buffer) {\n            if ($line =~ /^(\\w+):\\h*(.*\\S)/) {\n                $conf{$1} = $2;\n            }\n        }\n\n        if (exists $conf{cmscore1} and exists $conf{sentence1}) {\n            my @vals = split(' ', $conf{cmscore1});\n            if (sum(@vals) == @vals) {    # 'cmscore1' must be: 1.000 1.000 1.000 1.000\n                take_action($conf{sentence1});\n            }\n        }\n\n        $#buffer = -1;\n    }\n\n    push @buffer, $_;\n}\n\n__END__\npass1_best: <s> START MUSIC\npass1_best_wordseq: 0 2 3\npass1_best_phonemeseq: sil | y ah ng | w ah n\npass1_best_score: -4008.542480\n### Recognition: 2nd pass (RL heuristic best-first)\nSTAT: 00 _default: 7 generated, 7 pushed, 5 nodes popped in 100\nsentence1: <s> START MUSIC </s>\nwseq1: 0 2 3 1\nphseq1: sil | y ah ng | w ah n | sil\ncmscore1: 1.000 1.000 1.000 1.000\nscore1: -11499.305664\n\n#################################\n## __VOCA_FILE__ (perl.voca)\n#################################\n% NS_B\n<s>        sil\n\n% NS_E\n</s>        sil\n\n% CMD\nSTART      y ah ng\n\n% THING\nMUSIC     w ah n\nTERM      s eh v ax n\n\n######################################\n## __GRAMMAR_FILE__ (perl.grammar)\n######################################\nS : NS_B CMD THING_LOOP NS_E\nTHING_LOOP: THING_LOOP THING\nTHING_LOOP: THING\n"
  },
  {
    "path": "Microphone/Julius/voice_control.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 08 April 2014\n# Website: https://github.com/trizen\n\n# Voice control - take actions based on vocal commands\n# Configuration, grammar and .voca files: https://github.com/trizen/config-files/tree/master/.voxforge/julius\n\nuse utf8;\nuse 5.010;\nuse strict;\nuse warnings;\nuse List::Util qw(sum);\n\nno if $] >= 5.018, warnings => 'experimental';\n\nmy %forks;\nmy $config = \"$ENV{HOME}/.voxforge/julius/perl.jconf\";\nmy @julius = qw(julius -input mic);\n\nopen(my $pipe_h, '-|', @julius, '-C', $config) // exit $!;\n\nsub take_action {\n    my ($command) = @_;\n\n    given ($command) {\n        when ('<s> PLAY MUSIC </s>') {\n            say \"Starting music...\";\n            push @{$forks{music}}, scalar fork();\n            if ($forks{music}[-1] == 0) {\n                exec \"mpv $ENV{HOME}/*.mp3\";\n            }\n        }\n        when ('<s> STOP MUSIC </s>') {\n            say \"Stoping music...\";\n            if (ref $forks{music} eq 'ARRAY' and @{$forks{music}} > 0) {\n                kill 1, $forks{music}[-1];\n                pop @{$forks{music}};\n            }\n        }\n        when ('<s> RUN TERM </s>') {\n            say \"Opening the terminal...\";\n        }\n        when ('<s> RUN EDITOR </s>') {\n            say \"Running editor...\";\n        }\n        when ('<s> PRESS ENTER </s>') {\n            print \"\\n\";\n        }\n        default {\n            warn \"WARN: Invalid command `$command'!\\n\";\n        }\n    }\n}\n\nmy @buffer;\nwhile (<$pipe_h>) {\n\n    if (!/\\S/) {\n        my %conf;\n        foreach my $line (@buffer) {\n            if ($line =~ /^(\\w+):\\h*(.*\\S)/) {\n                $conf{$1} = $2;\n            }\n        }\n\n        if (exists $conf{cmscore1} and exists $conf{sentence1}) {\n            my @vals = split(' ', $conf{cmscore1});\n            say \"got: $conf{sentence1} ($conf{cmscore1})\";\n\n            # 'cmscore1' should be: 1.000 1.000 1.000 1.000 (with minor tolerance)\n            if (sum(@vals) >= scalar(@vals) - 0.300) {\n                take_action($conf{sentence1});\n            }\n        }\n\n        $#buffer = -1;\n    }\n\n    push @buffer, $_;\n}\n\n__END__\npass1_best: <s> START MUSIC\npass1_best_wordseq: 0 2 3\npass1_best_phonemeseq: sil | y ah ng | w ah n\npass1_best_score: -4008.542480\n### Recognition: 2nd pass (RL heuristic best-first)\nSTAT: 00 _default: 7 generated, 7 pushed, 5 nodes popped in 100\nsentence1: <s> START MUSIC </s>\nwseq1: 0 2 3 1\nphseq1: sil | y ah ng | w ah n | sil\ncmscore1: 1.000 1.000 1.000 1.000\nscore1: -11499.305664\n"
  },
  {
    "path": "Monitoring/file-monitor",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 10 April 2012\n# https://github.com/trizen\n\n# Monitor a path for updated files, new files and deleted files.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse File::Find qw(find);\nuse Time::HiRes qw(sleep);\nuse Getopt::Std qw(getopts);\nuse File::Spec::Functions qw(rel2abs);\n\nsub usage {\n    print <<\"USAGE\";\nusage: $0 [options] [files] [dirs]\n\noptions:\n        -c [i] : monitor for changes interval (in sec)\n        -n [i] : monitor for new files interval (in sec)\n        -v     : verbose mode\nUSAGE\n    exit 1;\n}\n\n# Arguments\nmy %opts;\ngetopts('c:n:v', \\%opts);\n\nmy %files;\nmy @files       = grep { -f } @ARGV;\nmy @directories = grep { -d } @ARGV;\n\nif (!@files and !@directories) {\n    usage();\n}\nelse {\n    if (@directories) {\n        populate_files(1);\n    }\n    foreach my $file (map { rel2abs($_) } @files) {\n        $files{$file} = [-M $file, 0];\n    }\n}\n\nmy $monitor_for_changes_interval   = $opts{c} // 8;\nmy $monitor_for_new_files_interval = $opts{n} // $monitor_for_changes_interval**2;\n\nsub populate_files {\n    my ($first_time) = @_;\n    find {\n        no_chdir => 1,\n        wanted   => sub {\n            -f or return;\n            -M _ // return;\n            $files{$_} =\n              exists $files{$_}\n              ? [$files{$_}[0] => 0]\n              : [-M _ => $first_time ? 0 : 1];\n          }\n         } => @directories;\n}\n\nmy $track = 0;\n\nwhile (1) {\n    while (my ($file, $info) = each %files) {\n        if (not -f $file) {\n            printf \"[DELETED]: %s\\n\", $file;\n            delete $files{$file};\n        }\n        elsif ($info->[1]) {\n            printf \"[CREATED]: %s\\n\", $file;\n            $files{$file}[1] = 0;\n        }\n        elsif (-M _ != $info->[0]) {\n            printf \"[UPDATED]: %s\\n\", $file;\n            $files{$file}[0] = -M _;\n        }\n    }\n\n    sleep $monitor_for_changes_interval;\n    printf STDERR \"[TOTAL_F]: %d\\n\", scalar keys %files if $opts{v};\n\n    if (($track += $monitor_for_changes_interval) >= $monitor_for_new_files_interval) {\n        warn \"[$track] Looking for new files...\\n\" if $opts{v};\n        populate_files(0) if @directories;\n        $track = 0;\n    }\n}\n"
  },
  {
    "path": "Other/concatenation_weirdness.pl",
    "content": "#!/usr/bin/perl\n\n# Weird order of concatenation of variables, when the variables are mutated during concatenation.\n\n# In older versions of Perl, the first statement correctly returns \"abc\".\n# In newer versions of Perl, both statements return incorrect values.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nmy $x = 'a';\nmy $y = 'b';\n\nsay ($x . $y . ++$y);       #=> expected \"abc\", but got \"acc\"\nsay ($x . ++$x);            #=> expected \"ab\", but got \"bb\"\n"
  },
  {
    "path": "Other/lexical_subs_recursion_bug.pl",
    "content": "#!/usr/bin/perl\n\n# Perl bug when using recursion in a `my sub {}` with a parent function.\n\nuse 5.014;\nuse strict;\nuse warnings;\n\n# Discovered by catb0t:\n#   https://github.com/catb0t/multifactor/commit/d2a8ad217704182f3b71557aa81a1a62f0ea2414\n\nsub factorial {\n    my ($n) = @_;\n\n    my sub my_func {\n        my ($n) = @_;\n        $n <= 1 ? 1 : $n * factorial($n - 1);\n    }\n\n    my_func($n);\n}\n\nsay factorial(5);\n\n__END__\nCan't undef active subroutine at bug.pl line 17.\n"
  },
  {
    "path": "Other/tail_recursion.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 04 January 2017\n# https://github.com/trizen\n\n# A simple example for tail-recursion in Perl.\n\nuse 5.016;\nuse strict;\nuse warnings;\n\nsub factorial {\n    my ($n, $fac) = @_;\n    return $fac if $n == 0;\n    @_ = ($n-1, $n*$fac);\n    goto __SUB__;\n}\n\nsay factorial(5, 1);\n"
  },
  {
    "path": "Other/yafu_factorization.pl",
    "content": "#!/usr/bin/perl\n\n# Factorize a given number, using the `YAFU` tool, and parse the output into an array of `Math::GMPz` objects.\n\n# See also:\n#   https://sourceforge.net/projects/yafu/\n\nuse 5.020;\nuse strict;\nuse warnings;\nuse Math::GMPz;\n\nuse experimental qw(signatures);\nuse File::Spec::Functions qw(rel2abs curdir tmpdir);\n\nsub yafu_factor ($n) {\n\n    $n = Math::GMPz->new($n);    # validate the number\n\n    my $dir = rel2abs(curdir());\n\n    chdir(tmpdir());\n    my $output = qx(yafu 'factor($n)');\n    chdir($dir);\n\n    my @factors;\n\n    while ($output =~ /^P\\d+ = (\\d+)/mg) {\n        push @factors, Math::GMPz->new($1);\n    }\n\n    return sort { $a <=> $b } @factors;\n}\n\nmy $n = shift() || die \"usage: $0 [n]\\n\";\n\nmy @factors = yafu_factor($n);\nsay \"$n = [\", join(', ', @factors), ']';\n"
  },
  {
    "path": "README.md",
    "content": "perl-scripts\n============\n\nA nice collection of day-to-day Perl scripts.\n\n### Summary\n\n* Analyzers\n    * [Char counter](./Analyzers/char_counter.pl)\n    * [Chr freq](./Analyzers/chr_freq.pl)\n    * [Dieharder](./Analyzers/dieharder.pl)\n    * [First letter top](./Analyzers/first_letter_top.pl)\n    * kcal\n        * [Kcal](./Analyzers/kcal/kcal.pl)\n    * [Kernel config diff](./Analyzers/kernel_config_diff.pl)\n    * [Perl code analyzer](./Analyzers/perl_code_analyzer.pl)\n    * [Perl code spellcheck](./Analyzers/perl_code_spellcheck.pl)\n    * [Reptop](./Analyzers/reptop.pl)\n    * [Text stats](./Analyzers/text_stats.pl)\n    * [Unidecode word top](./Analyzers/unidecode_word_top.pl)\n    * [Wcer](./Analyzers/wcer.pl)\n    * [Word suffix top](./Analyzers/word_suffix_top.pl)\n* Audio\n    * [Auto-mp3tags](./Audio/auto-mp3tags.pl)\n    * [Group audio files](./Audio/group_audio_files.pl)\n    * [Mkv audio to opus](./Audio/mkv_audio_to_opus.pl)\n    * [Recompress audio track](./Audio/recompress_audio_track.pl)\n    * [Rem-mp3tags](./Audio/rem-mp3tags.pl)\n    * [Wave-cmp](./Audio/wave-cmp.pl)\n    * [Wave-cmp2](./Audio/wave-cmp2.pl)\n* Benchmarks\n    * [Array range vs shift](./Benchmarks/array_range_vs_shift.pl)\n    * [Compression algorithms](./Benchmarks/compression_algorithms.pl)\n    * [Json vs storable](./Benchmarks/json_vs_storable.pl)\n    * [Schwartzian transform](./Benchmarks/schwartzian_transform.pl)\n    * [Types of variables](./Benchmarks/types_of_variables.pl)\n* Book tools\n    * [Rosettacode to markdown](./Book%20tools/rosettacode_to_markdown.pl)\n    * [Update summary](./Book%20tools/update_summary.pl)\n* Compression\n    * [Bbwr file compression](./Compression/bbwr_file_compression.pl)\n    * [Bqof file compression](./Compression/bqof_file_compression.pl)\n    * [Bwac file compression](./Compression/bwac_file_compression.pl)\n    * [Bwad file compression](./Compression/bwad_file_compression.pl)\n    * [Bwaz file compression](./Compression/bwaz_file_compression.pl)\n    * [Bwlz2 file compression](./Compression/bwlz2_file_compression.pl)\n    * [Bwlz file compression](./Compression/bwlz_file_compression.pl)\n    * [Bwlza2 file compression](./Compression/bwlza2_file_compression.pl)\n    * [Bwlza file compression](./Compression/bwlza_file_compression.pl)\n    * [Bwlzad2 file compression](./Compression/bwlzad2_file_compression.pl)\n    * [Bwlzad file compression](./Compression/bwlzad_file_compression.pl)\n    * [Bwlzhd file compression](./Compression/bwlzhd_file_compression.pl)\n    * [Bwlzss file compression](./Compression/bwlzss_file_compression.pl)\n    * [Bwrl2 file compression](./Compression/bwrl2_file_compression.pl)\n    * [Bwrl file compression](./Compression/bwrl_file_compression.pl)\n    * [Bwrla file compression](./Compression/bwrla_file_compression.pl)\n    * [Bwrlz2 file compression](./Compression/bwrlz2_file_compression.pl)\n    * [Bwrlz file compression](./Compression/bwrlz_file_compression.pl)\n    * [Bwrm file compression](./Compression/bwrm_file_compression.pl)\n    * [Bwt2 file compression](./Compression/bwt2_file_compression.pl)\n    * [Bwt file compression](./Compression/bwt_file_compression.pl)\n    * [Bww file compression](./Compression/bww_file_compression.pl)\n    * [Bzip2 compressor](./Compression/bzip2_compressor.pl)\n    * [Bzip2 decompressor](./Compression/bzip2_decompressor.pl)\n    * [Bzip2 file compression](./Compression/bzip2_file_compression.pl)\n    * [Compress](./Compression/compress.pl)\n    * [Gzip2 file compression](./Compression/gzip2_file_compression.pl)\n    * [Gzip block type 1](./Compression/gzip_block_type_1.pl)\n    * [Gzip block type 1 huffman only](./Compression/gzip_block_type_1_huffman_only.pl)\n    * [Gzip block type 2](./Compression/gzip_block_type_2.pl)\n    * [Gzip block type 2 huffman only](./Compression/gzip_block_type_2_huffman_only.pl)\n    * [Gzip block type 2 simple](./Compression/gzip_block_type_2_simple.pl)\n    * [Gzip comment](./Compression/gzip_comment.pl)\n    * [Gzip decompressor](./Compression/gzip_decompressor.pl)\n    * [Gzip file compression](./Compression/gzip_file_compression.pl)\n    * [Gzip store](./Compression/gzip_store.pl)\n    * [Hfm file compression](./Compression/hfm_file_compression.pl)\n    * High-level\n        * [Ablz file compression](./Compression/High-level/ablz_file_compression.pl)\n        * [Bbwr file compression](./Compression/High-level/bbwr_file_compression.pl)\n        * [Blzss2 file compression](./Compression/High-level/blzss2_file_compression.pl)\n        * [Blzss file compression](./Compression/High-level/blzss_file_compression.pl)\n        * [Brlzss file compression](./Compression/High-level/brlzss_file_compression.pl)\n        * [Bwac file compression](./Compression/High-level/bwac_file_compression.pl)\n        * [Bwad file compression](./Compression/High-level/bwad_file_compression.pl)\n        * [Bwlz2 file compression](./Compression/High-level/bwlz2_file_compression.pl)\n        * [Bwlz3 file compression](./Compression/High-level/bwlz3_file_compression.pl)\n        * [Bwlz file compression](./Compression/High-level/bwlz_file_compression.pl)\n        * [Bwlza2 file compression](./Compression/High-level/bwlza2_file_compression.pl)\n        * [Bwlza file compression](./Compression/High-level/bwlza_file_compression.pl)\n        * [Bwlzad2 file compression](./Compression/High-level/bwlzad2_file_compression.pl)\n        * [Bwlzad file compression](./Compression/High-level/bwlzad_file_compression.pl)\n        * [Bwlzb file compression](./Compression/High-level/bwlzb_file_compression.pl)\n        * [Bwlzhd2 file compression](./Compression/High-level/bwlzhd2_file_compression.pl)\n        * [Bwlzhd file compression](./Compression/High-level/bwlzhd_file_compression.pl)\n        * [Bwlzss file compression](./Compression/High-level/bwlzss_file_compression.pl)\n        * [Bwrl2 file compression](./Compression/High-level/bwrl2_file_compression.pl)\n        * [Bwrm2 file compression](./Compression/High-level/bwrm2_file_compression.pl)\n        * [Bwrm file compression](./Compression/High-level/bwrm_file_compression.pl)\n        * [Bwt2 file compression](./Compression/High-level/bwt2_file_compression.pl)\n        * [Bwt file compression](./Compression/High-level/bwt_file_compression.pl)\n        * [Bzip2 file compression](./Compression/High-level/bzip2_file_compression.pl)\n        * [Gzip file compression](./Compression/High-level/gzip_file_compression.pl)\n        * [Hblz file compression](./Compression/High-level/hblz_file_compression.pl)\n        * [Lz255 file compression](./Compression/High-level/lz255_file_compression.pl)\n        * [Lz2ss file compression](./Compression/High-level/lz2ss_file_compression.pl)\n        * [Lz4 file compression](./Compression/High-level/lz4_file_compression.pl)\n        * [Lz772 file compression](./Compression/High-level/lz772_file_compression.pl)\n        * [Lz77 file compression](./Compression/High-level/lz77_file_compression.pl)\n        * [Lz77f file compression](./Compression/High-level/lz77f_file_compression.pl)\n        * [Lzac file compression](./Compression/High-level/lzac_file_compression.pl)\n        * [Lzb file compression](./Compression/High-level/lzb_file_compression.pl)\n        * [Lzbbw file compression](./Compression/High-level/lzbbw_file_compression.pl)\n        * [Lzbf file compression](./Compression/High-level/lzbf_file_compression.pl)\n        * [Lzbh file compression](./Compression/High-level/lzbh_file_compression.pl)\n        * [Lzbw2 file compression](./Compression/High-level/lzbw2_file_compression.pl)\n        * [Lzbw3 file compression](./Compression/High-level/lzbw3_file_compression.pl)\n        * [Lzbw4 file compression](./Compression/High-level/lzbw4_file_compression.pl)\n        * [Lzbw5 file compression](./Compression/High-level/lzbw5_file_compression.pl)\n        * [Lzbw file compression](./Compression/High-level/lzbw_file_compression.pl)\n        * [Lzbwa file compression](./Compression/High-level/lzbwa_file_compression.pl)\n        * [Lzbwad file compression](./Compression/High-level/lzbwad_file_compression.pl)\n        * [Lzbwd file compression](./Compression/High-level/lzbwd_file_compression.pl)\n        * [Lzbwh file compression](./Compression/High-level/lzbwh_file_compression.pl)\n        * [Lzbws file compression](./Compression/High-level/lzbws_file_compression.pl)\n        * [Lzhd2 file compression](./Compression/High-level/lzhd2_file_compression.pl)\n        * [Lzhd file compression](./Compression/High-level/lzhd_file_compression.pl)\n        * [Lzih file compression](./Compression/High-level/lzih_file_compression.pl)\n        * [Lzmrl2 file compression](./Compression/High-level/lzmrl2_file_compression.pl)\n        * [Lzmrl file compression](./Compression/High-level/lzmrl_file_compression.pl)\n        * [Lzop file compression](./Compression/High-level/lzop_file_compression.pl)\n        * [Lzsbw file compression](./Compression/High-level/lzsbw_file_compression.pl)\n        * [Lzss2 file compression](./Compression/High-level/lzss2_file_compression.pl)\n        * [Lzss77 file compression](./Compression/High-level/lzss77_file_compression.pl)\n        * [Lzss file compression](./Compression/High-level/lzss_file_compression.pl)\n        * [Lzssf file compression](./Compression/High-level/lzssf_file_compression.pl)\n        * [Lzssm file compression](./Compression/High-level/lzssm_file_compression.pl)\n        * [Lzw file compression](./Compression/High-level/lzw_file_compression.pl)\n        * [Mblz file compression](./Compression/High-level/mblz_file_compression.pl)\n        * [Mbwr file compression](./Compression/High-level/mbwr_file_compression.pl)\n        * [Mrl file compression](./Compression/High-level/mrl_file_compression.pl)\n        * [Mybzip2 file compression](./Compression/High-level/mybzip2_file_compression.pl)\n        * [Mygzip file compression](./Compression/High-level/mygzip_file_compression.pl)\n        * [Mygzipf file compression](./Compression/High-level/mygzipf_file_compression.pl)\n        * [Mylz4 file compression](./Compression/High-level/mylz4_file_compression.pl)\n        * [Mylz4f file compression](./Compression/High-level/mylz4f_file_compression.pl)\n        * [Myzlib file compression](./Compression/High-level/myzlib_file_compression.pl)\n        * [Rablz file compression](./Compression/High-level/rablz_file_compression.pl)\n        * [Rlzss file compression](./Compression/High-level/rlzss_file_compression.pl)\n        * [Sbwt file compression](./Compression/High-level/sbwt_file_compression.pl)\n        * [Xz file compression](./Compression/High-level/xz_file_compression.pl)\n        * [Zlib file compression](./Compression/High-level/zlib_file_compression.pl)\n        * [Zstd file compression](./Compression/High-level/zstd_file_compression.pl)\n    * [Lz4 compressor](./Compression/lz4_compressor.pl)\n    * [Lz4 decompressor](./Compression/lz4_decompressor.pl)\n    * [Lz4 file compression](./Compression/lz4_file_compression.pl)\n    * [Lz77 file compression](./Compression/lz77_file_compression.pl)\n    * [Lza file compression](./Compression/lza_file_compression.pl)\n    * [Lzac file compression](./Compression/lzac_file_compression.pl)\n    * [Lzaz file compression](./Compression/lzaz_file_compression.pl)\n    * [Lzb2 file compression](./Compression/lzb2_file_compression.pl)\n    * [Lzb file compression](./Compression/lzb_file_compression.pl)\n    * [Lzbf2 file compression](./Compression/lzbf2_file_compression.pl)\n    * [Lzbf file compression](./Compression/lzbf_file_compression.pl)\n    * [Lzbh file compression](./Compression/lzbh_file_compression.pl)\n    * [Lzbw file compression](./Compression/lzbw_file_compression.pl)\n    * [Lzbwa file compression](./Compression/lzbwa_file_compression.pl)\n    * [Lzbwad file compression](./Compression/lzbwad_file_compression.pl)\n    * [Lzbwd file compression](./Compression/lzbwd_file_compression.pl)\n    * [Lzbwh file compression](./Compression/lzbwh_file_compression.pl)\n    * [Lzh file compression](./Compression/lzh_file_compression.pl)\n    * [Lzhc file compression](./Compression/lzhc_file_compression.pl)\n    * [Lzhd file compression](./Compression/lzhd_file_compression.pl)\n    * [Lzih file compression](./Compression/lzih_file_compression.pl)\n    * [Lzsa file compression](./Compression/lzsa_file_compression.pl)\n    * [Lzsad file compression](./Compression/lzsad_file_compression.pl)\n    * [Lzsbw file compression](./Compression/lzsbw_file_compression.pl)\n    * [Lzss2 file compression](./Compression/lzss2_file_compression.pl)\n    * [Lzss file compression](./Compression/lzss_file_compression.pl)\n    * [Lzssf file compression](./Compression/lzssf_file_compression.pl)\n    * [Lzsst2 file compression](./Compression/lzsst2_file_compression.pl)\n    * [Lzsst file compression](./Compression/lzsst_file_compression.pl)\n    * [Lzt2 file compression](./Compression/lzt2_file_compression.pl)\n    * [Lzt file compression](./Compression/lzt_file_compression.pl)\n    * [Lzw file compression](./Compression/lzw_file_compression.pl)\n    * [Mbwr file compression](./Compression/mbwr_file_compression.pl)\n    * [Mra file compression](./Compression/mra_file_compression.pl)\n    * [Mrh file compression](./Compression/mrh_file_compression.pl)\n    * [Mrlz file compression](./Compression/mrlz_file_compression.pl)\n    * [Ppmh file compression](./Compression/ppmh_file_compression.pl)\n    * [Qof file compression](./Compression/qof_file_compression.pl)\n    * [Rans file compression](./Compression/rans_file_compression.pl)\n    * [Rlac file compression](./Compression/rlac_file_compression.pl)\n    * [Rlh file compression](./Compression/rlh_file_compression.pl)\n    * [Tac file compression](./Compression/tac_file_compression.pl)\n    * [Tacc file compression](./Compression/tacc_file_compression.pl)\n    * [Test compressors](./Compression/test_compressors.pl)\n    * [Tzip2 file compression](./Compression/tzip2_file_compression.pl)\n    * [Tzip file compression](./Compression/tzip_file_compression.pl)\n    * [Unzip](./Compression/unzip.pl)\n    * [Zip](./Compression/zip.pl)\n    * [Zlib compressor](./Compression/zlib_compressor.pl)\n    * [Zlib decompressor](./Compression/zlib_decompressor.pl)\n    * [Zlib file compression](./Compression/zlib_file_compression.pl)\n* Converters\n    * [Another notes to markdown](./Converters/another_notes_to_markdown.pl)\n    * [Another notes to material notes](./Converters/another_notes_to_material_notes.pl)\n    * [Any to 3gp](./Converters/any_to_3gp.pl)\n    * [Ass2srt](./Converters/ass2srt.pl)\n    * [Code2pdf](./Converters/code2pdf.pl)\n    * [Euler2pdf](./Converters/euler2pdf.pl)\n    * [From hex](./Converters/from_hex.pl)\n    * [Gdbm to berkeley](./Converters/gdbm_to_berkeley.pl)\n    * [Gitbook2pdf](./Converters/gitbook2pdf.pl)\n    * [Gz2xz](./Converters/gz2xz.pl)\n    * [Html2pdf](./Converters/html2pdf.pl)\n    * [Html2pdf chromium](./Converters/html2pdf_chromium.pl)\n    * [Html2text](./Converters/html2text.pl)\n    * [Json2csv](./Converters/json2csv.pl)\n    * [Markdown2pdf](./Converters/markdown2pdf.pl)\n    * [Markdown2pdf chromium](./Converters/markdown2pdf_chromium.pl)\n    * [Markdown2text](./Converters/markdown2text.pl)\n    * [Notepadfree to txt](./Converters/notepadfree_to_txt.pl)\n    * [Pod2pdf](./Converters/pod2pdf.pl)\n    * [Pod2text](./Converters/pod2text.pl)\n    * [Recompress](./Converters/recompress.pl)\n    * [Unicode2ascii](./Converters/unicode2ascii.pl)\n    * [Vnt2txt simple](./Converters/vnt2txt_simple.pl)\n    * [Xml2hash](./Converters/xml2hash.pl)\n    * [Xpm c to perl](./Converters/xpm_c_to_perl.pl)\n    * [Xz2gz](./Converters/xz2gz.pl)\n    * [Zip2tar](./Converters/zip2tar.pl)\n    * [Zip2tar fast](./Converters/zip2tar_fast.pl)\n* Decoders\n    * [Base64 decoding-tutorial](./Decoders/base64_decoding-tutorial.pl)\n    * [Cnp info](./Decoders/cnp_info.pl)\n    * [Named parameters](./Decoders/named_parameters.pl)\n* Digest\n    * [Brute-force resistant hashing](./Digest/brute-force_resistant_hashing.pl)\n    * [Crc32](./Digest/crc32.pl)\n* Encoding\n    * [Adaptive huffman coding](./Encoding/adaptive_huffman_coding.pl)\n    * [Arithmetic coding](./Encoding/arithmetic_coding.pl)\n    * [Arithmetic coding adaptive contexts in fixed bits](./Encoding/arithmetic_coding_adaptive_contexts_in_fixed_bits.pl)\n    * [Arithmetic coding adaptive in fixed bits](./Encoding/arithmetic_coding_adaptive_in_fixed_bits.pl)\n    * [Arithmetic coding anynum](./Encoding/arithmetic_coding_anynum.pl)\n    * [Arithmetic coding in fixed bits](./Encoding/arithmetic_coding_in_fixed_bits.pl)\n    * [Arithmetic coding mpz](./Encoding/arithmetic_coding_mpz.pl)\n    * [Ascii encode decode](./Encoding/ascii_encode_decode.pl)\n    * [Binary arithmetic coding](./Encoding/binary_arithmetic_coding.pl)\n    * [Binary arithmetic coding anynum](./Encoding/binary_arithmetic_coding_anynum.pl)\n    * [Binary variable length run encoding](./Encoding/binary_variable_length_run_encoding.pl)\n    * [Binradix arithmetic coding](./Encoding/binradix_arithmetic_coding.pl)\n    * [Binradix arithmetic coding anynum](./Encoding/binradix_arithmetic_coding_anynum.pl)\n    * [Burrows-wheeler file transform](./Encoding/burrows-wheeler_file_transform.pl)\n    * [Burrows-wheeler transform](./Encoding/burrows-wheeler_transform.pl)\n    * [Burrows-wheeler transform-n-char generalization](./Encoding/burrows-wheeler_transform-n-char_generalization.pl)\n    * [Burrows-wheeler transform symbolic](./Encoding/burrows-wheeler_transform_symbolic.pl)\n    * [Delta encoding with double-elias coding](./Encoding/delta_encoding_with_double-elias_coding.pl)\n    * [Delta encoding with elias coding](./Encoding/delta_encoding_with_elias_coding.pl)\n    * [Delta encoding with unary coding](./Encoding/delta_encoding_with_unary_coding.pl)\n    * [Delta rle elias encoding](./Encoding/delta_rle_elias_encoding.pl)\n    * [Double-elias gamma encoding](./Encoding/double-elias_gamma_encoding.pl)\n    * [Elias gamma encoding](./Encoding/elias_gamma_encoding.pl)\n    * [Eyes dropper](./Encoding/eyes_dropper.pl)\n    * [Fibonacci coding](./Encoding/fibonacci_coding.pl)\n    * [Huffman coding](./Encoding/huffman_coding.pl)\n    * [Int2bytes](./Encoding/int2bytes.pl)\n    * [Integers binary encoding](./Encoding/integers_binary_encoding.pl)\n    * [Integers binary encoding with delta coding](./Encoding/integers_binary_encoding_with_delta_coding.pl)\n    * [Integers binary encoding with huffman coding](./Encoding/integers_binary_encoding_with_huffman_coding.pl)\n    * [Jpeg transform](./Encoding/jpeg_transform.pl)\n    * [Length encoder](./Encoding/length_encoder.pl)\n    * [Lz77 encoding](./Encoding/lz77_encoding.pl)\n    * [Lz77 encoding symbolic](./Encoding/lz77_encoding_symbolic.pl)\n    * [Lzss encoding](./Encoding/lzss_encoding.pl)\n    * [Lzss encoding hash table](./Encoding/lzss_encoding_hash_table.pl)\n    * [Lzss encoding hash table fast](./Encoding/lzss_encoding_hash_table_fast.pl)\n    * [Lzss encoding symbolic](./Encoding/lzss_encoding_symbolic.pl)\n    * [Lzt-fast](./Encoding/lzt-fast.pl)\n    * [Lzw encoding](./Encoding/lzw_encoding.pl)\n    * [Math expr encoder](./Encoding/math_expr_encoder.pl)\n    * [Move-to-front transform](./Encoding/move-to-front_transform.pl)\n    * [Mtf-delta encoding](./Encoding/mtf-delta_encoding.pl)\n    * [Png transform](./Encoding/png_transform.pl)\n    * [Ppm encoding](./Encoding/ppm_encoding.pl)\n    * [Ppm encoding dynamic](./Encoding/ppm_encoding_dynamic.pl)\n    * [RANS encoding](./Encoding/rANS_encoding.pl)\n    * [RANS encoding mpz](./Encoding/rANS_encoding_mpz.pl)\n    * [Run length with elias coding](./Encoding/run_length_with_elias_coding.pl)\n    * [String to integer encoding based on primes](./Encoding/string_to_integer_encoding_based_on_primes.pl)\n    * [Swap transform](./Encoding/swap_transform.pl)\n    * [Tlen encoding](./Encoding/tlen_encoding.pl)\n    * [Variable length run encoding](./Encoding/variable_length_run_encoding.pl)\n* Encryption\n    * [Age-lf](./Encryption/age-lf.pl)\n    * [Backdoored rsa with x25519](./Encryption/backdoored_rsa_with_x25519.pl)\n    * [Cbc+xor file encrypter](./Encryption/cbc+xor_file_encrypter.pl)\n    * [Crypt rsa](./Encryption/crypt_rsa.pl)\n    * [One-time pad](./Encryption/one-time_pad.pl)\n    * [Plage](./Encryption/plage.pl)\n    * [RSA encryption](./Encryption/RSA_encryption.pl)\n    * [Simple XOR cipher](./Encryption/simple_XOR_cipher.pl)\n* File Readers\n    * [Ldump](./File%20Readers/ldump)\n    * [Multi-file-line-reader](./File%20Readers/multi-file-line-reader.pl)\n    * [N repeated lines](./File%20Readers/n_repeated_lines.pl)\n    * [Tailz](./File%20Readers/tailz)\n* File Workers\n    * [Arxiv pdf renamer](./File%20Workers/arxiv_pdf_renamer.pl)\n    * [Auto extensions](./File%20Workers/auto_extensions.pl)\n    * [Collect gifs](./File%20Workers/collect_gifs.pl)\n    * [Collect videos](./File%20Workers/collect_videos.pl)\n    * [Delete if exists](./File%20Workers/delete_if_exists.pl)\n    * [Dir file updater](./File%20Workers/dir_file_updater.pl)\n    * [File-mover](./File%20Workers/file-mover.pl)\n    * [File updater](./File%20Workers/file_updater.pl)\n    * [Filename cmp del](./File%20Workers/filename_cmp_del.pl)\n    * [Keep this formats](./File%20Workers/keep_this_formats.pl)\n    * [Make filenames portable](./File%20Workers/make_filenames_portable.pl)\n    * [Md5 rename](./File%20Workers/md5_rename.pl)\n    * [Multiple backups](./File%20Workers/multiple_backups.pl)\n    * [Remove eof newlines](./File%20Workers/remove_eof_newlines.pl)\n    * [Split to n lines](./File%20Workers/split_to_n_lines.pl)\n    * [Sub renamer](./File%20Workers/sub_renamer.pl)\n    * [Timestamp rename](./File%20Workers/timestamp_rename.pl)\n    * [Undir](./File%20Workers/undir.pl)\n    * [Unidec renamer](./File%20Workers/unidec_renamer.pl)\n* Finders\n    * [Ampath](./Finders/ampath)\n    * [Dup subtr finder](./Finders/dup_subtr_finder.pl)\n    * [Fcheck](./Finders/fcheck.pl)\n    * [Fdf](./Finders/fdf)\n    * [Fdf-attr](./Finders/fdf-attr)\n    * [Fdf-filename](./Finders/fdf-filename)\n    * [File binsearch](./Finders/file_binsearch.pl)\n    * [Find perl scripts](./Finders/find_perl_scripts.pl)\n    * [Find similar filenames](./Finders/find_similar_filenames.pl)\n    * [Find similar filenames unidec](./Finders/find_similar_filenames_unidec.pl)\n    * [Fsf](./Finders/fsf.pl)\n    * [Fsfn](./Finders/fsfn.pl)\n    * [Human-like finder](./Finders/human-like_finder.pl)\n    * [Large file search](./Finders/large_file_search.pl)\n    * [Locatepm](./Finders/locatepm)\n    * [Longest substring](./Finders/longest_substring.pl)\n    * [Mimefind](./Finders/mimefind.pl)\n    * [Model matching system](./Finders/model_matching_system.pl)\n    * [Path diff](./Finders/path_diff.pl)\n    * [Plocate](./Finders/plocate.pl)\n    * [Similar files levenshtein](./Finders/similar_files_levenshtein.pl)\n* Formatters\n    * [Ascii table csv](./Formatters/ascii_table_csv.pl)\n    * [File columner](./Formatters/file_columner.pl)\n    * [Fstab beautifier](./Formatters/fstab_beautifier.pl)\n    * [Js beautify](./Formatters/js_beautify)\n    * [Reformat literal perl strings](./Formatters/reformat_literal_perl_strings.pl)\n    * [Replace html links](./Formatters/replace_html_links.pl)\n    * [Sort perl subroutines](./Formatters/sort_perl_subroutines.pl)\n    * [Word columner](./Formatters/word_columner.pl)\n* Game solvers\n    * [Asciiplanes-player](./Game%20solvers/asciiplanes-player.pl)\n    * [Asciiplanes-player-v2](./Game%20solvers/asciiplanes-player-v2.pl)\n    * [Dice game solver](./Game%20solvers/dice_game_solver.pl)\n    * [Peg-solitaire-solver](./Game%20solvers/peg-solitaire-solver)\n    * [Reaction time test](./Game%20solvers/reaction_time_test.pl)\n    * [Reflex sheep game](./Game%20solvers/reflex_sheep_game.pl)\n    * [Sudoku dice game solver](./Game%20solvers/sudoku_dice_game_solver.pl)\n    * [Sudoku generator](./Game%20solvers/sudoku_generator.pl)\n    * [Sudoku solver](./Game%20solvers/sudoku_solver.pl)\n    * [Sudoku solver backtracking](./Game%20solvers/sudoku_solver_backtracking.pl)\n    * [Sudoku solver iterative](./Game%20solvers/sudoku_solver_iterative.pl)\n    * [Sudoku solver stack](./Game%20solvers/sudoku_solver_stack.pl)\n    * [Visual memory test](./Game%20solvers/visual_memory_test.pl)\n* Games\n    * [Arrow-key drawer](./Games/arrow-key_drawer.pl)\n    * [Asciiplanes](./Games/asciiplanes)\n    * [Snake game](./Games/snake_game.pl)\n* GD\n    * [Abstract map](./GD/abstract_map.pl)\n    * [AND sierpinski triangle](./GD/AND_sierpinski_triangle.pl)\n    * [Barnsley fern fractal](./GD/barnsley_fern_fractal.pl)\n    * [Binary triangle](./GD/binary_triangle.pl)\n    * [Black star turtle](./GD/black_star_turtle.pl)\n    * [Black yellow number triangles](./GD/black_yellow_number_triangles.pl)\n    * [Box pattern](./GD/box_pattern.pl)\n    * [Chaos game pentagon](./GD/chaos_game_pentagon.pl)\n    * [Chaos game tetrahedron](./GD/chaos_game_tetrahedron.pl)\n    * [Chaos game triangle](./GD/chaos_game_triangle.pl)\n    * [Circular prime triangle](./GD/circular_prime_triangle.pl)\n    * [Circular triangle](./GD/circular_triangle.pl)\n    * [Collatz triangle](./GD/collatz_triangle.pl)\n    * [Color wheel](./GD/color_wheel.pl)\n    * [Complex square](./GD/complex_square.pl)\n    * [Congruence of squares triangle](./GD/congruence_of_squares_triangle.pl)\n    * [Cuboid turtle](./GD/cuboid_turtle.pl)\n    * [Cuboid turtle3](./GD/cuboid_turtle3.pl)\n    * [Cuboid turtle 2](./GD/cuboid_turtle_2.pl)\n    * [Dancing shapes](./GD/dancing_shapes.pl)\n    * [Divisor circles](./GD/divisor_circles.pl)\n    * [Divisor triangle](./GD/divisor_triangle.pl)\n    * [Elementary cellular automaton generalized](./GD/elementary_cellular_automaton_generalized.pl)\n    * [Fact exp primorial growing](./GD/fact_exp_primorial_growing.pl)\n    * [Factor circles](./GD/factor_circles.pl)\n    * [Factor triangle](./GD/factor_triangle.pl)\n    * [Factorial turtles](./GD/factorial_turtles.pl)\n    * [Factors of two triangle](./GD/factors_of_two_triangle.pl)\n    * [Farey turnings plot](./GD/farey_turnings_plot.pl)\n    * [Fgraph](./GD/fgraph.pl)\n    * [Fgraph precision](./GD/fgraph_precision.pl)\n    * [Fibonacci gd](./GD/fibonacci_gd.pl)\n    * [Fibonacci spirals](./GD/fibonacci_spirals.pl)\n    * [Generator turtle](./GD/generator_turtle.pl)\n    * [Geometric shapes](./GD/geometric_shapes.pl)\n    * [Goldbach conjecture possibilities](./GD/goldbach_conjecture_possibilities.pl)\n    * [Horsie art](./GD/horsie_art.pl)\n    * [Julia set](./GD/julia_set.pl)\n    * [Julia set complex](./GD/julia_set_complex.pl)\n    * [Julia set random](./GD/julia_set_random.pl)\n    * [Julia set rperl](./GD/julia_set_rperl.pl)\n    * [Koch snowflakes](./GD/koch_snowflakes.pl)\n    * [Langton's ant gd](./GD/langton_s_ant_gd.pl)\n    * [Line pattern triangles](./GD/line_pattern_triangles.pl)\n    * LSystem\n        * [Honeycomb](./GD/LSystem/honeycomb.pl)\n        * [Honeycomb 2](./GD/LSystem/honeycomb_2.pl)\n        * [LSystem.pm](./GD/LSystem/LSystem.pm)\n        * [Plant](./GD/LSystem/plant.pl)\n        * [Plant 2](./GD/LSystem/plant_2.pl)\n        * [Plant 3](./GD/LSystem/plant_3.pl)\n        * [Sierpinski triangle](./GD/LSystem/sierpinski_triangle.pl)\n        * [Tree](./GD/LSystem/tree.pl)\n        * [Turtle.pm](./GD/LSystem/Turtle.pm)\n    * [Magic triangle](./GD/magic_triangle.pl)\n    * [Mandelbrot like set](./GD/mandelbrot_like_set.pl)\n    * [Mandelbrot like set gcomplex](./GD/mandelbrot_like_set_gcomplex.pl)\n    * [Mathematical butt](./GD/mathematical_butt.pl)\n    * [Mathematical shapes](./GD/mathematical_shapes.pl)\n    * [Mirror shells](./GD/mirror_shells.pl)\n    * [Moebius walking line](./GD/moebius_walking_line.pl)\n    * [Number triangles](./GD/number_triangles.pl)\n    * [Numeric circles](./GD/numeric_circles.pl)\n    * [Pascal-fibonacci triangle](./GD/pascal-fibonacci_triangle.pl)\n    * [Pascal powers of two triangle](./GD/pascal_powers_of_two_triangle.pl)\n    * [Pascal's triangle multiples](./GD/pascal_s_triangle_multiples.pl)\n    * [Pascal special triangle](./GD/pascal_special_triangle.pl)\n    * [Pattern triangle](./GD/pattern_triangle.pl)\n    * [Peacock triangles](./GD/peacock_triangles.pl)\n    * [Pi abstract art](./GD/pi_abstract_art.pl)\n    * [Pi turtle](./GD/pi_turtle.pl)\n    * [Prime consecutive sums](./GD/prime_consecutive_sums.pl)\n    * [Prime gaps](./GD/prime_gaps.pl)\n    * [Prime rectangles](./GD/prime_rectangles.pl)\n    * [Prime stripe triangle](./GD/prime_stripe_triangle.pl)\n    * [Prime triangle 90deg](./GD/prime_triangle_90deg.pl)\n    * [Pythagoras tree](./GD/pythagoras_tree.pl)\n    * [Random abstract art](./GD/random_abstract_art.pl)\n    * [Random abstract art 2](./GD/random_abstract_art_2.pl)\n    * [Random langton's ant](./GD/random_langton_s_ant.pl)\n    * [Random looking pattern triangle](./GD/random_looking_pattern_triangle.pl)\n    * [Random machinery art](./GD/random_machinery_art.pl)\n    * [Random noise triangle](./GD/random_noise_triangle.pl)\n    * [Random turtles](./GD/random_turtles.pl)\n    * [Real shell](./GD/real_shell.pl)\n    * [Recursive squares](./GD/recursive_squares.pl)\n    * [Regular poligons](./GD/regular_poligons.pl)\n    * [Reversed prime triangles](./GD/reversed_prime_triangles.pl)\n    * [Right triangle primes](./GD/right_triangle_primes.pl)\n    * [Sandpiles](./GD/sandpiles.pl)\n    * [Sierpinski fibonacci triangle](./GD/sierpinski_fibonacci_triangle.pl)\n    * [Sierpinski triangle](./GD/sierpinski_triangle.pl)\n    * [Spinning shapes](./GD/spinning_shapes.pl)\n    * [Spiral matrix primes](./GD/spiral_matrix_primes.pl)\n    * [Spiral tree](./GD/spiral_tree.pl)\n    * [Square of circles](./GD/square_of_circles.pl)\n    * [Star turtle](./GD/star_turtle.pl)\n    * [Stern brocot shapes](./GD/stern_brocot_shapes.pl)\n    * [Triangle factors](./GD/triangle_factors.pl)\n    * [Triangle primes](./GD/triangle_primes.pl)\n    * [Triangle primes 2](./GD/triangle_primes_2.pl)\n    * [Triangle primes irregular](./GD/triangle_primes_irregular.pl)\n    * [Trizen fan turtle](./GD/trizen_fan_turtle.pl)\n    * [Trizen flat logo](./GD/trizen_flat_logo.pl)\n    * [Trizen new logo](./GD/trizen_new_logo.pl)\n    * [Trizen old logo](./GD/trizen_old_logo.pl)\n    * [Trizen text art](./GD/trizen_text_art.pl)\n    * [Tupper's self-referential formula](./GD/tupper_s_self-referential_formula.pl)\n    * [Wavy triangle](./GD/wavy_triangle.pl)\n    * [XOR pattern](./GD/XOR_pattern.pl)\n    * [Zeta real half terms](./GD/zeta_real_half_terms.pl)\n    * [Zig-zag primes](./GD/zig-zag_primes.pl)\n* Generators\n    * [Bernoulli numbers formulas](./Generators/bernoulli_numbers_formulas.pl)\n    * [Faulhaber's formula symbolic](./Generators/faulhaber_s_formula_symbolic.pl)\n    * [Faulhaber's formulas expanded](./Generators/faulhaber_s_formulas_expanded.pl)\n    * [Faulhaber's formulas expanded 2](./Generators/faulhaber_s_formulas_expanded_2.pl)\n    * [Faulhaber's formulas generator](./Generators/faulhaber_s_formulas_generator.pl)\n    * [Parsing and code gen](./Generators/parsing_and_code_gen.pl)\n    * [Powers of factorial](./Generators/powers_of_factorial.pl)\n    * [Random lsystem generator](./Generators/random_lsystem_generator.pl)\n    * [Semiprime equationization C generator](./Generators/semiprime_equationization_C_generator.pl)\n    * [Semiprime equationization Perl generator](./Generators/semiprime_equationization_Perl_generator.pl)\n    * [Zeta 2n generator](./Generators/zeta_2n_generator.pl)\n* Greppers\n    * [Marif](./Greppers/marif)\n    * [Mime types](./Greppers/mime_types.pl)\n    * [Mp3grep](./Greppers/mp3grep.pl)\n    * [Scgrep](./Greppers/scgrep)\n    * [Unigrep](./Greppers/unigrep.pl)\n* GTK+\n    * [Mouse position](./GTK+/mouse_position.pl)\n    * [Tray-file-browser](./GTK+/tray-file-browser.pl)\n* HAL\n    * HAL3736\n        * [HAL3736.memory](./HAL/HAL3736/HAL3736.memory)\n        * [HAL3736](./HAL/HAL3736/HAL3736.pl)\n    * HAL8212\n        * [HAL8212.memory](./HAL/HAL8212/HAL8212.memory)\n        * [HAL8212](./HAL/HAL8212/HAL8212.pl)\n    * HAL9000\n        * [HAL9000.memory](./HAL/HAL9000/HAL9000.memory)\n        * [HAL9000](./HAL/HAL9000/HAL9000.pl)\n* Image\n    * [2x zoom](./Image/2x_zoom.pl)\n    * [Add exif info](./Image/add_exif_info.pl)\n    * [Bitmap monochrome encoding decoding](./Image/bitmap_monochrome_encoding_decoding.pl)\n    * [Bwt horizontal transform](./Image/bwt_horizontal_transform.pl)\n    * [Bwt rgb horizontal transform](./Image/bwt_rgb_horizontal_transform.pl)\n    * [Bwt rgb vertical transform](./Image/bwt_rgb_vertical_transform.pl)\n    * [Bwt vertical transform](./Image/bwt_vertical_transform.pl)\n    * [Collage](./Image/collage.pl)\n    * [Complex transform](./Image/complex_transform.pl)\n    * [Cyan vision](./Image/cyan_vision.pl)\n    * [Darken image](./Image/darken_image.pl)\n    * [Diff negative](./Image/diff_negative.pl)\n    * [Edge detector](./Image/edge_detector.pl)\n    * [Extract jpegs](./Image/extract_jpegs.pl)\n    * [Fractal frame](./Image/fractal_frame.pl)\n    * [Fractal frame transparent](./Image/fractal_frame_transparent.pl)\n    * [Gd png2jpg](./Image/gd_png2jpg.pl)\n    * [Gd similar images](./Image/gd_similar_images.pl)\n    * [Gd star trails](./Image/gd_star_trails.pl)\n    * [Gif2webp](./Image/gif2webp.pl)\n    * [Horizontal scrambler](./Image/horizontal_scrambler.pl)\n    * [Image-hard-rotate](./Image/image-hard-rotate.pl)\n    * [Image-unpack](./Image/image-unpack.pl)\n    * [Image2ascii](./Image/image2ascii.pl)\n    * [Image2audio](./Image/image2audio.pl)\n    * [Image2digits](./Image/image2digits.pl)\n    * [Image2html](./Image/image2html.pl)\n    * [Image2matrix](./Image/image2matrix.pl)\n    * [Image2mozaic](./Image/image2mozaic.pl)\n    * [Image2png](./Image/image2png.pl)\n    * [Image2prime](./Image/image2prime.pl)\n    * [Image metadata clone](./Image/image_metadata_clone.pl)\n    * [Imager similar images](./Image/imager_similar_images.pl)\n    * [Img-autocrop](./Image/img-autocrop.pl)\n    * [Img-autocrop-avg](./Image/img-autocrop-avg.pl)\n    * [Img-autocrop-whitebg](./Image/img-autocrop-whitebg.pl)\n    * [Img composition](./Image/img_composition.pl)\n    * [Img rewrite](./Image/img_rewrite.pl)\n    * [Julia transform](./Image/julia_transform.pl)\n    * [Lookalike images](./Image/lookalike_images.pl)\n    * [Magick png2jpg](./Image/magick_png2jpg.pl)\n    * [Magick similar images](./Image/magick_similar_images.pl)\n    * [Magick star trails](./Image/magick_star_trails.pl)\n    * [Matrix visual](./Image/matrix_visual.pl)\n    * [Mirror images](./Image/mirror_images.pl)\n    * [Mtf horizontal transform](./Image/mtf_horizontal_transform.pl)\n    * [Mtf vertical transform](./Image/mtf_vertical_transform.pl)\n    * [Nearest neighbor interpolation](./Image/nearest_neighbor_interpolation.pl)\n    * [Optimize images](./Image/optimize_images.pl)\n    * [Optimize images littleutils](./Image/optimize_images_littleutils.pl)\n    * [Outguess-png](./Image/outguess-png.pl)\n    * [Outguess-png-imager](./Image/outguess-png-imager.pl)\n    * [Photo mosaic from images](./Image/photo_mosaic_from_images.pl)\n    * [Qhi decoder](./Image/qhi_decoder.pl)\n    * [Qhi encoder](./Image/qhi_encoder.pl)\n    * [Qoi decoder](./Image/qoi_decoder.pl)\n    * [Qoi encoder](./Image/qoi_encoder.pl)\n    * [Qzst decoder](./Image/qzst_decoder.pl)\n    * [Qzst encoder](./Image/qzst_encoder.pl)\n    * [Recompress images](./Image/recompress_images.pl)\n    * [Remove sensitive exif tags](./Image/remove_sensitive_exif_tags.pl)\n    * [Resize images](./Image/resize_images.pl)\n    * [Rgb dump](./Image/rgb_dump.pl)\n    * [Sharp 2x zoom](./Image/sharp_2x_zoom.pl)\n    * [Slideshow](./Image/slideshow.pl)\n    * [Vertical scrambler](./Image/vertical_scrambler.pl)\n    * [Visualize binary](./Image/visualize_binary.pl)\n    * [Webp2png](./Image/webp2png.pl)\n    * [Zuper image decoder](./Image/zuper_image_decoder.pl)\n    * [Zuper image encoder](./Image/zuper_image_encoder.pl)\n* JAPH\n    * [Alien japh](./JAPH/alien_japh.pl)\n    * [Alpha ascii japh](./JAPH/alpha_ascii_japh.pl)\n    * [Alpha japh](./JAPH/alpha_japh.pl)\n    * [Alpha japh 2](./JAPH/alpha_japh_2.pl)\n    * [Alpha japh 3](./JAPH/alpha_japh_3.pl)\n    * [Arrow japh](./JAPH/arrow_japh.pl)\n    * [Barewords japh](./JAPH/barewords_japh.pl)\n    * [Cubic japh](./JAPH/cubic_japh.pl)\n    * [Invisible japh](./JAPH/invisible_japh.pl)\n    * [Japh from ambiguity](./JAPH/japh_from_ambiguity.pl)\n    * [Japh from auto-quoted keywords](./JAPH/japh_from_auto-quoted_keywords.pl)\n    * [Japh from escapes](./JAPH/japh_from_escapes.pl)\n    * [Japh from escapes 2](./JAPH/japh_from_escapes_2.pl)\n    * [Japh from eval subst](./JAPH/japh_from_eval_subst.pl)\n    * [Japh from keywords](./JAPH/japh_from_keywords.pl)\n    * [Japh from pod](./JAPH/japh_from_pod.pl)\n    * [Japh from poetry](./JAPH/japh_from_poetry.pl)\n    * [Japh from punctuation chars](./JAPH/japh_from_punctuation_chars.pl)\n    * [Japh from subs](./JAPH/japh_from_subs.pl)\n    * [Japh from the deep](./JAPH/japh_from_the_deep.pl)\n    * [Japh variable](./JAPH/japh_variable.pl)\n    * [Japh variables](./JAPH/japh_variables.pl)\n    * [Japh variables 2](./JAPH/japh_variables_2.pl)\n    * [Leet japh](./JAPH/leet_japh.pl)\n    * [Length obfuscation](./JAPH/length_obfuscation.pl)\n    * [Log japh](./JAPH/log_japh.pl)\n    * [Log japh 2](./JAPH/log_japh_2.pl)\n    * [Non-alphanumeric japh](./JAPH/non-alphanumeric_japh.pl)\n    * [Re eval japh](./JAPH/re_eval_japh.pl)\n    * [Slash r japh](./JAPH/slash_r_japh.pl)\n    * [Ternary japh](./JAPH/ternary_japh.pl)\n    * [Up and down](./JAPH/up_and_down.pl)\n    * [Vec japh](./JAPH/vec_japh.pl)\n    * [Vec japh 2](./JAPH/vec_japh_2.pl)\n* Lingua\n    * [En phoneme](./Lingua/en_phoneme.pl)\n    * [Lingua ro numbers](./Lingua/lingua_ro_numbers.pl)\n    * [Poetry from poetry](./Lingua/poetry_from_poetry.pl)\n    * [Poetry from poetry with variations](./Lingua/poetry_from_poetry_with_variations.pl)\n    * [Random poetry generator](./Lingua/random_poetry_generator.pl)\n    * [Rus translit](./Lingua/rus_translit.pl)\n* Math\n    * [1 over n is finite](./Math/1_over_n_is_finite.pl)\n    * [1 over n period length](./Math/1_over_n_period_length.pl)\n    * [Additive binomial](./Math/additive_binomial.pl)\n    * [Additive partitions](./Math/additive_partitions.pl)\n    * [Alexandrian integers](./Math/alexandrian_integers.pl)\n    * [Almost prime divisors](./Math/almost_prime_divisors.pl)\n    * [Almost prime divisors recursive](./Math/almost_prime_divisors_recursive.pl)\n    * [Almost prime numbers](./Math/almost_prime_numbers.pl)\n    * [Almost prime numbers in range](./Math/almost_prime_numbers_in_range.pl)\n    * [Almost prime numbers in range mpz](./Math/almost_prime_numbers_in_range_mpz.pl)\n    * [Almost prime numbers in range v2](./Math/almost_prime_numbers_in_range_v2.pl)\n    * [Almost primes from factor list](./Math/almost_primes_from_factor_list.pl)\n    * [Almost primes in range from factor list](./Math/almost_primes_in_range_from_factor_list.pl)\n    * [Area of triangle](./Math/area_of_triangle.pl)\n    * [Arithmetic derivative](./Math/arithmetic_derivative.pl)\n    * [Arithmetic expressions](./Math/arithmetic_expressions.pl)\n    * [Arithmetic geometric mean complex](./Math/arithmetic_geometric_mean_complex.pl)\n    * [Arithmetic sum closed form](./Math/arithmetic_sum_closed_form.pl)\n    * [Ascii cuboid](./Math/ascii_cuboid.pl)\n    * [Ascii julia set](./Math/ascii_julia_set.pl)\n    * [Ascii mandelbrot set](./Math/ascii_mandelbrot_set.pl)\n    * [Batir factorial asymptotic formula mpfr](./Math/batir_factorial_asymptotic_formula_mpfr.pl)\n    * [Bell numbers](./Math/bell_numbers.pl)\n    * [Bell numbers mpz](./Math/bell_numbers_mpz.pl)\n    * [Bernoulli denominators](./Math/bernoulli_denominators.pl)\n    * [Bernoulli denominators records](./Math/bernoulli_denominators_records.pl)\n    * [Bernoulli numbers](./Math/bernoulli_numbers.pl)\n    * [Bernoulli numbers from factorials](./Math/bernoulli_numbers_from_factorials.pl)\n    * [Bernoulli numbers from factorials mpq](./Math/bernoulli_numbers_from_factorials_mpq.pl)\n    * [Bernoulli numbers from factorials mpz](./Math/bernoulli_numbers_from_factorials_mpz.pl)\n    * [Bernoulli numbers from factorials visual](./Math/bernoulli_numbers_from_factorials_visual.pl)\n    * [Bernoulli numbers from primes](./Math/bernoulli_numbers_from_primes.pl)\n    * [Bernoulli numbers from primes gmpf](./Math/bernoulli_numbers_from_primes_gmpf.pl)\n    * [Bernoulli numbers from primes mpfr](./Math/bernoulli_numbers_from_primes_mpfr.pl)\n    * [Bernoulli numbers from primes ntheory](./Math/bernoulli_numbers_from_primes_ntheory.pl)\n    * [Bernoulli numbers from tangent numbers](./Math/bernoulli_numbers_from_tangent_numbers.pl)\n    * [Bernoulli numbers from zeta](./Math/bernoulli_numbers_from_zeta.pl)\n    * [Bernoulli numbers ramanujan congruences](./Math/bernoulli_numbers_ramanujan_congruences.pl)\n    * [Bernoulli numbers ramanujan congruences unreduced](./Math/bernoulli_numbers_ramanujan_congruences_unreduced.pl)\n    * [Bernoulli numbers recursive](./Math/bernoulli_numbers_recursive.pl)\n    * [Bernoulli numbers recursive 2](./Math/bernoulli_numbers_recursive_2.pl)\n    * [Bernoulli numbers seidel](./Math/bernoulli_numbers_seidel.pl)\n    * [Bi-unitary divisors](./Math/bi-unitary_divisors.pl)\n    * [Binary gcd algorithm](./Math/binary_gcd_algorithm.pl)\n    * [Binary gcd algorithm mpz](./Math/binary_gcd_algorithm_mpz.pl)\n    * [Binary multiplier](./Math/binary_multiplier.pl)\n    * [Binary prime encoder](./Math/binary_prime_encoder.pl)\n    * [Binary prime encoder fast](./Math/binary_prime_encoder_fast.pl)\n    * [Binary prime sieve mpz](./Math/binary_prime_sieve_mpz.pl)\n    * [Binary splitting product](./Math/binary_splitting_product.pl)\n    * [Binomial sum with imaginary term](./Math/binomial_sum_with_imaginary_term.pl)\n    * [Binomial theorem](./Math/binomial_theorem.pl)\n    * [Bitstring prime sieve mpz](./Math/bitstring_prime_sieve_mpz.pl)\n    * [Bitstring prime sieve vec](./Math/bitstring_prime_sieve_vec.pl)\n    * [Both truncatable primes in base](./Math/both_truncatable_primes_in_base.pl)\n    * [BPSW primality test](./Math/BPSW_primality_test.pl)\n    * [BPSW primality test mpz](./Math/BPSW_primality_test_mpz.pl)\n    * [Brazilian primes constant](./Math/brazilian_primes_constant.pl)\n    * [Brown numbers](./Math/brown_numbers.pl)\n    * [Carmichael factorization method](./Math/carmichael_factorization_method.pl)\n    * [Carmichael factorization method generalized](./Math/carmichael_factorization_method_generalized.pl)\n    * [Carmichael numbers from multiple](./Math/carmichael_numbers_from_multiple.pl)\n    * [Carmichael numbers from multiple mpz](./Math/carmichael_numbers_from_multiple_mpz.pl)\n    * [Carmichael numbers from multiple recursive mpz](./Math/carmichael_numbers_from_multiple_recursive_mpz.pl)\n    * [Carmichael numbers generation erdos method](./Math/carmichael_numbers_generation_erdos_method.pl)\n    * [Carmichael numbers generation erdos method dynamic programming](./Math/carmichael_numbers_generation_erdos_method_dynamic_programming.pl)\n    * [Carmichael numbers in range](./Math/carmichael_numbers_in_range.pl)\n    * [Carmichael numbers in range from prime factors](./Math/carmichael_numbers_in_range_from_prime_factors.pl)\n    * [Carmichael numbers in range mpz](./Math/carmichael_numbers_in_range_mpz.pl)\n    * [Carmichael numbers random](./Math/carmichael_numbers_random.pl)\n    * [Carmichael strong fermat pseudoprimes in range](./Math/carmichael_strong_fermat_pseudoprimes_in_range.pl)\n    * [Carmichael strong fermat pseudoprimes in range mpz](./Math/carmichael_strong_fermat_pseudoprimes_in_range_mpz.pl)\n    * [Cartesian product iter](./Math/cartesian_product_iter.pl)\n    * [Cartesian product rec](./Math/cartesian_product_rec.pl)\n    * [Cauchy numbers of first type](./Math/cauchy_numbers_of_first_type.pl)\n    * [Chebyshev factorization method](./Math/chebyshev_factorization_method.pl)\n    * [Chebyshev factorization method mpz](./Math/chebyshev_factorization_method_mpz.pl)\n    * [Chernick-carmichael numbers](./Math/chernick-carmichael_numbers.pl)\n    * [Chernick-carmichael numbers below limit](./Math/chernick-carmichael_numbers_below_limit.pl)\n    * [Chernick-carmichael polynomials](./Math/chernick-carmichael_polynomials.pl)\n    * [Chernick-carmichael with n factors sieve](./Math/chernick-carmichael_with_n_factors_sieve.pl)\n    * [Chinese factorization method](./Math/chinese_factorization_method.pl)\n    * [Coin change](./Math/coin_change.pl)\n    * [Collatz function](./Math/collatz_function.pl)\n    * [Complex exponentiation in real numbers](./Math/complex_exponentiation_in_real_numbers.pl)\n    * [Complex logarithm in real numbers](./Math/complex_logarithm_in_real_numbers.pl)\n    * [Complex modular multiplicative inverse](./Math/complex_modular_multiplicative_inverse.pl)\n    * [Complex zeta in real numbers](./Math/complex_zeta_in_real_numbers.pl)\n    * [Congruence of powers factorization method](./Math/congruence_of_powers_factorization_method.pl)\n    * [Consecutive partitions](./Math/consecutive_partitions.pl)\n    * [Continued fraction expansion of sqrt of n](./Math/continued_fraction_expansion_of_sqrt_of_n.pl)\n    * [Continued fraction expansion of sqrt of n mpz](./Math/continued_fraction_expansion_of_sqrt_of_n_mpz.pl)\n    * [Continued fraction factorization method](./Math/continued_fraction_factorization_method.pl)\n    * [Continued fractions](./Math/continued_fractions.pl)\n    * [Continued fractions for e](./Math/continued_fractions_for_e.pl)\n    * [Continued fractions for nth roots](./Math/continued_fractions_for_nth_roots.pl)\n    * [Continued fractions for pi](./Math/continued_fractions_for_pi.pl)\n    * [Continued fractions for square roots](./Math/continued_fractions_for_square_roots.pl)\n    * [Continued fractions prime constant](./Math/continued_fractions_prime_constant.pl)\n    * [Convergent series](./Math/convergent_series.pl)\n    * [Cosmic calendar](./Math/cosmic_calendar.pl)\n    * [Count of brilliant numbers](./Math/count_of_brilliant_numbers.pl)\n    * [Count of cube-full numbers](./Math/count_of_cube-full_numbers.pl)\n    * [Count of integers with gpf of n equals p](./Math/count_of_integers_with_gpf_of_n_equals_p.pl)\n    * [Count of integers with lpf of n equals p](./Math/count_of_integers_with_lpf_of_n_equals_p.pl)\n    * [Count of inverse tau in range](./Math/count_of_inverse_tau_in_range.pl)\n    * [Count of k-almost primes](./Math/count_of_k-almost_primes.pl)\n    * [Count of k-omega primes](./Math/count_of_k-omega_primes.pl)\n    * [Count of k-powerfree numbers](./Math/count_of_k-powerfree_numbers.pl)\n    * [Count of k-powerful numbers](./Math/count_of_k-powerful_numbers.pl)\n    * [Count of k-powerful numbers in range](./Math/count_of_k-powerful_numbers_in_range.pl)\n    * [Count of perfect powers](./Math/count_of_perfect_powers.pl)\n    * [Count of prime power](./Math/count_of_prime_power.pl)\n    * [Count of prime signature numbers](./Math/count_of_prime_signature_numbers.pl)\n    * [Count of rough numbers](./Math/count_of_rough_numbers.pl)\n    * [Count of rough numbers recursive](./Math/count_of_rough_numbers_recursive.pl)\n    * [Count of smooth numbers](./Math/count_of_smooth_numbers.pl)\n    * [Count of smooth numbers memoized](./Math/count_of_smooth_numbers_memoized.pl)\n    * [Count of smooth numbers mpz](./Math/count_of_smooth_numbers_mpz.pl)\n    * [Count of smooth numbers mpz 2](./Math/count_of_smooth_numbers_mpz_2.pl)\n    * [Count of smooth numbers with k factors](./Math/count_of_smooth_numbers_with_k_factors.pl)\n    * [Count of squarefree k-almost primes](./Math/count_of_squarefree_k-almost_primes.pl)\n    * [Count of squarefree numbers](./Math/count_of_squarefree_numbers.pl)\n    * [Count subtriangles](./Math/count_subtriangles.pl)\n    * [Cube-full numbers](./Math/cube-full_numbers.pl)\n    * [Cuboid](./Math/cuboid.pl)\n    * [Cyclotomic factorization method](./Math/cyclotomic_factorization_method.pl)\n    * [Cyclotomic factorization method 2](./Math/cyclotomic_factorization_method_2.pl)\n    * [Cyclotomic polynomial](./Math/cyclotomic_polynomial.pl)\n    * [Definite integral numerical approximation](./Math/definite_integral_numerical_approximation.pl)\n    * [Dickson linear forms prime sieve](./Math/dickson_linear_forms_prime_sieve.pl)\n    * [Dickson linear forms prime sieve in range](./Math/dickson_linear_forms_prime_sieve_in_range.pl)\n    * [Dickson linear forms prime sieve in range 2](./Math/dickson_linear_forms_prime_sieve_in_range_2.pl)\n    * [Difference of k powers](./Math/difference_of_k_powers.pl)\n    * [Difference of powers factorization method](./Math/difference_of_powers_factorization_method.pl)\n    * [Difference of three squares solutions](./Math/difference_of_three_squares_solutions.pl)\n    * [Difference of two squares solutions](./Math/difference_of_two_squares_solutions.pl)\n    * [Digits to number subquadratic algorithm](./Math/digits_to_number_subquadratic_algorithm.pl)\n    * [Digits to number subquadratic algorithm mpz](./Math/digits_to_number_subquadratic_algorithm_mpz.pl)\n    * [Dirichlet hyperbola method](./Math/dirichlet_hyperbola_method.pl)\n    * [Discrete logarithm pollard rho](./Math/discrete_logarithm_pollard_rho.pl)\n    * [Discrete logarithm pollard rho mpz](./Math/discrete_logarithm_pollard_rho_mpz.pl)\n    * [Discrete root](./Math/discrete_root.pl)\n    * [Divisors descending lazy](./Math/divisors_descending_lazy.pl)\n    * [Divisors lazy](./Math/divisors_lazy.pl)\n    * [Divisors lazy fast](./Math/divisors_lazy_fast.pl)\n    * [Divisors less than k](./Math/divisors_less_than_k.pl)\n    * [Divisors of factorial below limit](./Math/divisors_of_factorial_below_limit.pl)\n    * [Divisors of factorial in range iterator](./Math/divisors_of_factorial_in_range_iterator.pl)\n    * [Dixon factorization method](./Math/dixon_factorization_method.pl)\n    * [E from binomial](./Math/e_from_binomial.pl)\n    * [E primorial](./Math/e_primorial.pl)\n    * [Ecm factorization method](./Math/ecm_factorization_method.pl)\n    * [Elementary cellular automaton generalized](./Math/elementary_cellular_automaton_generalized.pl)\n    * [Elliptic-curve factorization method](./Math/elliptic-curve_factorization_method.pl)\n    * [Elliptic-curve factorization method with B2 stage](./Math/elliptic-curve_factorization_method_with_B2_stage.pl)\n    * [Elliptic-curve factorization method with B2 stage mpz](./Math/elliptic-curve_factorization_method_with_B2_stage_mpz.pl)\n    * [Equally spaced squares solutions](./Math/equally_spaced_squares_solutions.pl)\n    * [Esthetic numbers](./Math/esthetic_numbers.pl)\n    * [Ethiopian multiplication](./Math/ethiopian_multiplication.pl)\n    * [Ethiopian multiplication binary](./Math/ethiopian_multiplication_binary.pl)\n    * [Even fermat pseudoprimes in range](./Math/even_fermat_pseudoprimes_in_range.pl)\n    * [Even squarefree fermat pseudoprimes in range](./Math/even_squarefree_fermat_pseudoprimes_in_range.pl)\n    * [Exponential divisors](./Math/exponential_divisors.pl)\n    * [Factorial difference of prime squares](./Math/factorial_difference_of_prime_squares.pl)\n    * [Factorial dsc algorithm](./Math/factorial_dsc_algorithm.pl)\n    * [Factorial expansion of reciprocals](./Math/factorial_expansion_of_reciprocals.pl)\n    * [Factorial from primes](./Math/factorial_from_primes.pl)\n    * [Factorial from primes simple](./Math/factorial_from_primes_simple.pl)\n    * [Factorial from primorials](./Math/factorial_from_primorials.pl)\n    * [Factorial from trinomial coefficients](./Math/factorial_from_trinomial_coefficients.pl)\n    * [Factorial in half steps](./Math/factorial_in_half_steps.pl)\n    * [Factorions in base n](./Math/factorions_in_base_n.pl)\n    * [Factorization with difference of prime factors](./Math/factorization_with_difference_of_prime_factors.pl)\n    * [Farey rational approximation](./Math/farey_rational_approximation.pl)\n    * [Faulhaber's formula](./Math/faulhaber_s_formula.pl)\n    * [Fermat factorization method](./Math/fermat_factorization_method.pl)\n    * [Fermat factorization method 2](./Math/fermat_factorization_method_2.pl)\n    * [Fermat frobenius quadratic primality test](./Math/fermat_frobenius_quadratic_primality_test.pl)\n    * [Fermat overpseudoprimes generation](./Math/fermat_overpseudoprimes_generation.pl)\n    * [Fermat overpseudoprimes in range](./Math/fermat_overpseudoprimes_in_range.pl)\n    * [Fermat pseudoprimes from multiple](./Math/fermat_pseudoprimes_from_multiple.pl)\n    * [Fermat pseudoprimes from multiple mpz](./Math/fermat_pseudoprimes_from_multiple_mpz.pl)\n    * [Fermat pseudoprimes generation](./Math/fermat_pseudoprimes_generation.pl)\n    * [Fermat pseudoprimes generation 2](./Math/fermat_pseudoprimes_generation_2.pl)\n    * [Fermat pseudoprimes generation 3](./Math/fermat_pseudoprimes_generation_3.pl)\n    * [Fermat pseudoprimes in range](./Math/fermat_pseudoprimes_in_range.pl)\n    * [Fermat pseudoprimes in range mpz](./Math/fermat_pseudoprimes_in_range_mpz.pl)\n    * [Fermat superpseudoprimes generation](./Math/fermat_superpseudoprimes_generation.pl)\n    * [Fibonacci closed form](./Math/fibonacci_closed_form.pl)\n    * [Fibonacci closed form 2](./Math/fibonacci_closed_form_2.pl)\n    * [Fibonacci encoding](./Math/fibonacci_encoding.pl)\n    * [Fibonacci factorization method](./Math/fibonacci_factorization_method.pl)\n    * [Fibonacci k-th order](./Math/fibonacci_k-th_order.pl)\n    * [Fibonacci k-th order efficient algorithm](./Math/fibonacci_k-th_order_efficient_algorithm.pl)\n    * [Fibonacci k-th order fast](./Math/fibonacci_k-th_order_fast.pl)\n    * [Fibonacci k-th order odd primes indices](./Math/fibonacci_k-th_order_odd_primes_indices.pl)\n    * [Fibonacci number fast](./Math/fibonacci_number_fast.pl)\n    * [Fibonacci polynomials closed form](./Math/fibonacci_polynomials_closed_form.pl)\n    * [Fibonacci pseudoprimes generation](./Math/fibonacci_pseudoprimes_generation.pl)\n    * [Find least common denominator](./Math/find_least_common_denominator.pl)\n    * [Floor and ceil functions fourier series](./Math/floor_and_ceil_functions_fourier_series.pl)\n    * [Flt factorization method](./Math/flt_factorization_method.pl)\n    * [Fraction approximation](./Math/fraction_approximation.pl)\n    * [Fraction to decimal expansion](./Math/fraction_to_decimal_expansion.pl)\n    * [Fractional pi](./Math/fractional_pi.pl)\n    * [Frobenius pseudoprimes generation](./Math/frobenius_pseudoprimes_generation.pl)\n    * [Fubini numbers](./Math/fubini_numbers.pl)\n    * [Fubini numbers 2](./Math/fubini_numbers_2.pl)\n    * [Fubini numbers recursive](./Math/fubini_numbers_recursive.pl)\n    * [Function graph](./Math/function_graph.pl)\n    * [Function inverse binary search](./Math/function_inverse_binary_search.pl)\n    * [Gamma function](./Math/gamma_function.pl)\n    * [Gaussian divisors](./Math/gaussian_divisors.pl)\n    * [Gaussian factors](./Math/gaussian_factors.pl)\n    * [Gaussian integers sum](./Math/gaussian_integers_sum.pl)\n    * [General binary multiplier](./Math/general_binary_multiplier.pl)\n    * [Goldbach conjecture 2n prime](./Math/goldbach_conjecture_2n_prime.pl)\n    * [Goldbach conjecture increasing primes](./Math/goldbach_conjecture_increasing_primes.pl)\n    * [Goldbach conjecture possibilities](./Math/goldbach_conjecture_possibilities.pl)\n    * [Goldbach conjecture random primes](./Math/goldbach_conjecture_random_primes.pl)\n    * [Golomb's sequence](./Math/golomb_s_sequence.pl)\n    * [Greatest common unitary divisor](./Math/greatest_common_unitary_divisor.pl)\n    * [Hamming numbers](./Math/hamming_numbers.pl)\n    * [Harmonic numbers](./Math/harmonic_numbers.pl)\n    * [Harmonic numbers from digamma](./Math/harmonic_numbers_from_digamma.pl)\n    * [Harmonic numbers from powers](./Math/harmonic_numbers_from_powers.pl)\n    * [Harmonic numbers from powers mpz](./Math/harmonic_numbers_from_powers_mpz.pl)\n    * [Harmonic prime powers](./Math/harmonic_prime_powers.pl)\n    * [Hybrid prime factorization](./Math/hybrid_prime_factorization.pl)\n    * [Infinitary divisors](./Math/infinitary_divisors.pl)\n    * [Inverse of bernoulli numbers](./Math/inverse_of_bernoulli_numbers.pl)\n    * [Inverse of euler totient](./Math/inverse_of_euler_totient.pl)\n    * [Inverse of factorial](./Math/inverse_of_factorial.pl)\n    * [Inverse of factorial stirling](./Math/inverse_of_factorial_stirling.pl)\n    * [Inverse of fibonacci](./Math/inverse_of_fibonacci.pl)\n    * [Inverse of multiplicative functions](./Math/inverse_of_multiplicative_functions.pl)\n    * [Inverse of p adic valuation](./Math/inverse_of_p_adic_valuation.pl)\n    * [Inverse of sigma function](./Math/inverse_of_sigma_function.pl)\n    * [Inverse of sigma function fast](./Math/inverse_of_sigma_function_fast.pl)\n    * [Inverse of sigma function generalized](./Math/inverse_of_sigma_function_generalized.pl)\n    * [Inverse of usigma function](./Math/inverse_of_usigma_function.pl)\n    * [Inverse tau in range](./Math/inverse_tau_in_range.pl)\n    * [Invert transform of factorials](./Math/invert_transform_of_factorials.pl)\n    * [Is absolute euler pseudoprime](./Math/is_absolute_euler_pseudoprime.pl)\n    * [Is almost prime](./Math/is_almost_prime.pl)\n    * [Is bfsw pseudoprime](./Math/is_bfsw_pseudoprime.pl)\n    * [Is chernick carmichael number](./Math/is_chernick_carmichael_number.pl)\n    * [Is even perfect](./Math/is_even_perfect.pl)\n    * [Is even perfect 2](./Math/is_even_perfect_2.pl)\n    * [Is even perfect 3](./Math/is_even_perfect_3.pl)\n    * [Is extra bfsw pseudoprime](./Math/is_extra_bfsw_pseudoprime.pl)\n    * [Is omega prime](./Math/is_omega_prime.pl)\n    * [Is perfect power](./Math/is_perfect_power.pl)\n    * [Is smooth over product](./Math/is_smooth_over_product.pl)\n    * [Is squarefree over product](./Math/is_squarefree_over_product.pl)\n    * [Is sum of two cubes](./Math/is_sum_of_two_cubes.pl)\n    * [Is sum of two squares](./Math/is_sum_of_two_squares.pl)\n    * [Iterative difference of central divisors to reach zero](./Math/iterative_difference_of_central_divisors_to_reach_zero.pl)\n    * [K-imperfect numbers](./Math/k-imperfect_numbers.pl)\n    * [K-odd-powerful numbers](./Math/k-odd-powerful_numbers.pl)\n    * [K-powerful numbers](./Math/k-powerful_numbers.pl)\n    * [K-powerful numbers in range](./Math/k-powerful_numbers_in_range.pl)\n    * [Karatsuba multiplication](./Math/karatsuba_multiplication.pl)\n    * [Kempner binomial numbers](./Math/kempner_binomial_numbers.pl)\n    * [Klein J invariant and modular lambda](./Math/klein_J_invariant_and_modular_lambda.pl)\n    * [Lambert W function](./Math/lambert_W_function.pl)\n    * [Lambert W function complex](./Math/lambert_W_function_complex.pl)\n    * [Lanczos approximation](./Math/lanczos_approximation.pl)\n    * [Least k such that k times k-th prime is greater than 10 to the n](./Math/least_k_such_that_k_times_k-th_prime_is_greater_than_10_to_the_n.pl)\n    * [Least nonresidue](./Math/least_nonresidue.pl)\n    * [Legendary question six](./Math/legendary_question_six.pl)\n    * [Length of shortest addition chain](./Math/length_of_shortest_addition_chain.pl)\n    * [Lerch zeta function](./Math/lerch_zeta_function.pl)\n    * [Logarithmic integral asymptotic formula](./Math/logarithmic_integral_asymptotic_formula.pl)\n    * [Logarithmic root](./Math/logarithmic_root.pl)\n    * [Logarithmic root complex](./Math/logarithmic_root_complex.pl)\n    * [Logarithmic root in two variables](./Math/logarithmic_root_in_two_variables.pl)\n    * [Logarithmic root mpfr](./Math/logarithmic_root_mpfr.pl)\n    * [Long division](./Math/long_division.pl)\n    * [Long multiplication](./Math/long_multiplication.pl)\n    * [Lucas-carmichael numbers from multiple](./Math/lucas-carmichael_numbers_from_multiple.pl)\n    * [Lucas-carmichael numbers from multiple mpz](./Math/lucas-carmichael_numbers_from_multiple_mpz.pl)\n    * [Lucas-carmichael numbers in range](./Math/lucas-carmichael_numbers_in_range.pl)\n    * [Lucas-carmichael numbers in range from prime factors](./Math/lucas-carmichael_numbers_in_range_from_prime_factors.pl)\n    * [Lucas-carmichael numbers in range mpz](./Math/lucas-carmichael_numbers_in_range_mpz.pl)\n    * [Lucas-miller factorization method](./Math/lucas-miller_factorization_method.pl)\n    * [Lucas-pocklington primality proving](./Math/lucas-pocklington_primality_proving.pl)\n    * [Lucas-pratt primality proving](./Math/lucas-pratt_primality_proving.pl)\n    * [Lucas-pratt prime records](./Math/lucas-pratt_prime_records.pl)\n    * [Lucas factorization method](./Math/lucas_factorization_method.pl)\n    * [Lucas factorization method generalized](./Math/lucas_factorization_method_generalized.pl)\n    * [Lucas pseudoprimes generation](./Math/lucas_pseudoprimes_generation.pl)\n    * [Lucas pseudoprimes generation erdos method](./Math/lucas_pseudoprimes_generation_erdos_method.pl)\n    * [Lucas sequences U V](./Math/lucas_sequences_U_V.pl)\n    * [Lucas sequences U V mpz](./Math/lucas_sequences_U_V_mpz.pl)\n    * [Lucas theorem](./Math/lucas_theorem.pl)\n    * [LUP decomposition](./Math/LUP_decomposition.pl)\n    * [Magic 3-gon ring](./Math/magic_3-gon_ring.pl)\n    * [Magic 5-gon ring](./Math/magic_5-gon_ring.pl)\n    * [Map num](./Math/map_num.pl)\n    * [Matrix determinant bareiss](./Math/matrix_determinant_bareiss.pl)\n    * [Matrix path 2-ways best](./Math/matrix_path_2-ways_best.pl)\n    * [Matrix path 2-ways greedy](./Math/matrix_path_2-ways_greedy.pl)\n    * [Matrix path 3-ways best](./Math/matrix_path_3-ways_best.pl)\n    * [Matrix path 3-ways diagonal best](./Math/matrix_path_3-ways_diagonal_best.pl)\n    * [Matrix path 3-ways greedy](./Math/matrix_path_3-ways_greedy.pl)\n    * [Matrix path 4-ways best](./Math/matrix_path_4-ways_best.pl)\n    * [Matrix path 4-ways best 2](./Math/matrix_path_4-ways_best_2.pl)\n    * [Matrix path 4-ways best 3](./Math/matrix_path_4-ways_best_3.pl)\n    * [Matrix path 4-ways greedy](./Math/matrix_path_4-ways_greedy.pl)\n    * [Maximum product of parts bisection](./Math/maximum_product_of_parts_bisection.pl)\n    * [Maximum square remainder](./Math/maximum_square_remainder.pl)\n    * [MBE factorization method](./Math/MBE_factorization_method.pl)\n    * [Meissel lehmer prime count](./Math/meissel_lehmer_prime_count.pl)\n    * [Mertens function](./Math/mertens_function.pl)\n    * [Mertens function fast](./Math/mertens_function_fast.pl)\n    * [Miller-rabin deterministic primality test](./Math/miller-rabin_deterministic_primality_test.pl)\n    * [Miller-rabin deterministic primality test mpz](./Math/miller-rabin_deterministic_primality_test_mpz.pl)\n    * [Miller-rabin factorization method](./Math/miller-rabin_factorization_method.pl)\n    * [Modular bell numbers](./Math/modular_bell_numbers.pl)\n    * [Modular bell numbers mpz](./Math/modular_bell_numbers_mpz.pl)\n    * [Modular binomial](./Math/modular_binomial.pl)\n    * [Modular binomial fast](./Math/modular_binomial_fast.pl)\n    * [Modular binomial faster](./Math/modular_binomial_faster.pl)\n    * [Modular binomial faster mpz](./Math/modular_binomial_faster_mpz.pl)\n    * [Modular binomial faster mpz 2](./Math/modular_binomial_faster_mpz_2.pl)\n    * [Modular binomial ntheory](./Math/modular_binomial_ntheory.pl)\n    * [Modular binomial small k](./Math/modular_binomial_small_k.pl)\n    * [Modular binomial small k faster](./Math/modular_binomial_small_k_faster.pl)\n    * [Modular cyclotomic polynomial](./Math/modular_cyclotomic_polynomial.pl)\n    * [Modular factorial](./Math/modular_factorial.pl)\n    * [Modular factorial crt](./Math/modular_factorial_crt.pl)\n    * [Modular factorial crt mpz](./Math/modular_factorial_crt_mpz.pl)\n    * [Modular fibonacci](./Math/modular_fibonacci.pl)\n    * [Modular fibonacci anynum](./Math/modular_fibonacci_anynum.pl)\n    * [Modular fibonacci cassini](./Math/modular_fibonacci_cassini.pl)\n    * [Modular fibonacci cassini fast](./Math/modular_fibonacci_cassini_fast.pl)\n    * [Modular fibonacci fast mpz](./Math/modular_fibonacci_fast_mpz.pl)\n    * [Modular fibonacci mpz](./Math/modular_fibonacci_mpz.pl)\n    * [Modular fibonacci polynomial](./Math/modular_fibonacci_polynomial.pl)\n    * [Modular fibonacci polynomial 2](./Math/modular_fibonacci_polynomial_2.pl)\n    * [Modular hyperoperation](./Math/modular_hyperoperation.pl)\n    * [Modular inverse](./Math/modular_inverse.pl)\n    * [Modular k-th root all solutions](./Math/modular_k-th_root_all_solutions.pl)\n    * [Modular k-th root all solutions fast](./Math/modular_k-th_root_all_solutions_fast.pl)\n    * [Modular k-th root all solutions fast mpz](./Math/modular_k-th_root_all_solutions_fast_mpz.pl)\n    * [Modular k-th root all solutions mpz](./Math/modular_k-th_root_all_solutions_mpz.pl)\n    * [Modular lucas numbers](./Math/modular_lucas_numbers.pl)\n    * [Modular lucas sequence V](./Math/modular_lucas_sequence_V.pl)\n    * [Modular lucas sequences U V](./Math/modular_lucas_sequences_U_V.pl)\n    * [Modular pseudo square root](./Math/modular_pseudo_square_root.pl)\n    * [Modular pseudo square root 2](./Math/modular_pseudo_square_root_2.pl)\n    * [Modular sigma of unitary divisors of factorial](./Math/modular_sigma_of_unitary_divisors_of_factorial.pl)\n    * [Modular square root](./Math/modular_square_root.pl)\n    * [Modular square root 2](./Math/modular_square_root_2.pl)\n    * [Modular square root 3](./Math/modular_square_root_3.pl)\n    * [Modular square root all solutions](./Math/modular_square_root_all_solutions.pl)\n    * [Modular square root all solutions cipolla](./Math/modular_square_root_all_solutions_cipolla.pl)\n    * [Multi sqrt nums](./Math/multi_sqrt_nums.pl)\n    * [Multinomial coefficient](./Math/multinomial_coefficient.pl)\n    * [Multinomial coefficient from binomial](./Math/multinomial_coefficient_from_binomial.pl)\n    * [Multiplicative partitions](./Math/multiplicative_partitions.pl)\n    * [Multisets](./Math/multisets.pl)\n    * [Multivariate gamma function](./Math/multivariate_gamma_function.pl)\n    * [Mysterious sum-pentagonal numbers](./Math/mysterious_sum-pentagonal_numbers.pl)\n    * [Mysterious sum-pentagonal numbers 2](./Math/mysterious_sum-pentagonal_numbers_2.pl)\n    * [N dimensional circles](./Math/n_dimensional_circles.pl)\n    * [Near-power factorization method](./Math/near-power_factorization_method.pl)\n    * [Newton's method](./Math/newton_s_method.pl)\n    * [Newton's method recursive](./Math/newton_s_method_recursive.pl)\n    * [Next palindrome](./Math/next_palindrome.pl)\n    * [Next palindrome from non-palindrome](./Math/next_palindrome_from_non-palindrome.pl)\n    * [Next palindrome in base](./Math/next_palindrome_in_base.pl)\n    * [Next power of two](./Math/next_power_of_two.pl)\n    * [Nth composite](./Math/nth_composite.pl)\n    * [Nth digit of fraction](./Math/nth_digit_of_fraction.pl)\n    * [Nth prime approx](./Math/nth_prime_approx.pl)\n    * [Nth root good rational approximations](./Math/nth_root_good_rational_approximations.pl)\n    * [Nth root recurrence constant](./Math/nth_root_recurrence_constant.pl)\n    * [Nth smooth number](./Math/nth_smooth_number.pl)\n    * [Number2expression](./Math/number2expression.pl)\n    * [Number of conditional GCDs](./Math/number_of_conditional_GCDs.pl)\n    * [Number of connected permutations](./Math/number_of_connected_permutations.pl)\n    * [Number of partitions into 2 distinct positive cubes](./Math/number_of_partitions_into_2_distinct_positive_cubes.pl)\n    * [Number of partitions into 2 distinct positive squares](./Math/number_of_partitions_into_2_distinct_positive_squares.pl)\n    * [Number of partitions into 2 nonnegative cubes](./Math/number_of_partitions_into_2_nonnegative_cubes.pl)\n    * [Number of partitions into 2 positive squares](./Math/number_of_partitions_into_2_positive_squares.pl)\n    * [Number of representations as sum of 3 triangles](./Math/number_of_representations_as_sum_of_3_triangles.pl)\n    * [Number of representations as sum of four squares](./Math/number_of_representations_as_sum_of_four_squares.pl)\n    * [Number of representations as sum of two squares](./Math/number_of_representations_as_sum_of_two_squares.pl)\n    * [Number to digits subquadratic algorithm](./Math/number_to_digits_subquadratic_algorithm.pl)\n    * [Number to digits subquadratic algorithm mpz](./Math/number_to_digits_subquadratic_algorithm_mpz.pl)\n    * [Numbers with pow 2 divisors](./Math/numbers_with_pow_2_divisors.pl)\n    * [Omega prime divisors](./Math/omega_prime_divisors.pl)\n    * [Omega prime numbers in range](./Math/omega_prime_numbers_in_range.pl)\n    * [Omega prime numbers in range mpz](./Math/omega_prime_numbers_in_range_mpz.pl)\n    * [Omega prime numbers in range simple](./Math/omega_prime_numbers_in_range_simple.pl)\n    * [Order factorization method](./Math/order_factorization_method.pl)\n    * [Palindrome iteration](./Math/palindrome_iteration.pl)\n    * [Partial sums of dedekind psi function](./Math/partial_sums_of_dedekind_psi_function.pl)\n    * [Partial sums of euler totient function](./Math/partial_sums_of_euler_totient_function.pl)\n    * [Partial sums of euler totient function fast](./Math/partial_sums_of_euler_totient_function_fast.pl)\n    * [Partial sums of euler totient function fast 2](./Math/partial_sums_of_euler_totient_function_fast_2.pl)\n    * [Partial sums of euler totient function times k](./Math/partial_sums_of_euler_totient_function_times_k.pl)\n    * [Partial sums of euler totient function times k to the m](./Math/partial_sums_of_euler_totient_function_times_k_to_the_m.pl)\n    * [Partial sums of exponential prime omega functions](./Math/partial_sums_of_exponential_prime_omega_functions.pl)\n    * [Partial sums of gcd-sum function](./Math/partial_sums_of_gcd-sum_function.pl)\n    * [Partial sums of gcd-sum function fast](./Math/partial_sums_of_gcd-sum_function_fast.pl)\n    * [Partial sums of gcd-sum function faster](./Math/partial_sums_of_gcd-sum_function_faster.pl)\n    * [Partial sums of generalized gcd-sum function](./Math/partial_sums_of_generalized_gcd-sum_function.pl)\n    * [Partial sums of gpf](./Math/partial_sums_of_gpf.pl)\n    * [Partial sums of inverse moebius transform of dedekind function](./Math/partial_sums_of_inverse_moebius_transform_of_dedekind_function.pl)\n    * [Partial sums of jordan totient function](./Math/partial_sums_of_jordan_totient_function.pl)\n    * [Partial sums of jordan totient function fast](./Math/partial_sums_of_jordan_totient_function_fast.pl)\n    * [Partial sums of jordan totient function times k to the m](./Math/partial_sums_of_jordan_totient_function_times_k_to_the_m.pl)\n    * [Partial sums of lcm count function](./Math/partial_sums_of_lcm_count_function.pl)\n    * [Partial sums of liouville function](./Math/partial_sums_of_liouville_function.pl)\n    * [Partial sums of lpf](./Math/partial_sums_of_lpf.pl)\n    * [Partial sums of n over k-almost prime divisors](./Math/partial_sums_of_n_over_k-almost_prime_divisors.pl)\n    * [Partial sums of powerfree numbers](./Math/partial_sums_of_powerfree_numbers.pl)\n    * [Partial sums of powerfree part](./Math/partial_sums_of_powerfree_part.pl)\n    * [Partial sums of prime bigomega function](./Math/partial_sums_of_prime_bigomega_function.pl)\n    * [Partial sums of prime omega function](./Math/partial_sums_of_prime_omega_function.pl)\n    * [Partial sums of sigma0 function](./Math/partial_sums_of_sigma0_function.pl)\n    * [Partial sums of sigma function](./Math/partial_sums_of_sigma_function.pl)\n    * [Partial sums of sigma function times k](./Math/partial_sums_of_sigma_function_times_k.pl)\n    * [Partial sums of sigma function times k to the m](./Math/partial_sums_of_sigma_function_times_k_to_the_m.pl)\n    * [Partitions count](./Math/partitions_count.pl)\n    * [Partitions count abs](./Math/partitions_count_abs.pl)\n    * [Partitions count simple](./Math/partitions_count_simple.pl)\n    * [Pascal-fibonacci triangle](./Math/pascal-fibonacci_triangle.pl)\n    * [Pascal's triangle multiples](./Math/pascal_s_triangle_multiples.pl)\n    * [Pattern mixing](./Math/pattern_mixing.pl)\n    * [Pell cfrac factorization](./Math/pell_cfrac_factorization.pl)\n    * [Pell factorization](./Math/pell_factorization.pl)\n    * [Pell factorization anynum](./Math/pell_factorization_anynum.pl)\n    * [Perfect numbers](./Math/perfect_numbers.pl)\n    * [Period of continued fraction for square roots](./Math/period_of_continued_fraction_for_square_roots.pl)\n    * [Period of continued fraction for square roots mpz](./Math/period_of_continued_fraction_for_square_roots_mpz.pl)\n    * [Period of continued fraction for square roots ntheory](./Math/period_of_continued_fraction_for_square_roots_ntheory.pl)\n    * [Phi-finder factorization method](./Math/phi-finder_factorization_method.pl)\n    * [Pi from infinity](./Math/pi_from_infinity.pl)\n    * [Pisano periods](./Math/pisano_periods.pl)\n    * [Pisano periods efficient algorithm](./Math/pisano_periods_efficient_algorithm.pl)\n    * [Pocklington-pratt primality proving](./Math/pocklington-pratt_primality_proving.pl)\n    * [Pollard-strassen factorization method](./Math/pollard-strassen_factorization_method.pl)\n    * [Pollard p-1 factorization](./Math/pollard_p-1_factorization.pl)\n    * [Pollard rho exp factorization](./Math/pollard_rho_exp_factorization.pl)\n    * [Pollard rho factorization](./Math/pollard_rho_factorization.pl)\n    * [Polygonal numbers](./Math/polygonal_numbers.pl)\n    * [Polygonal representations](./Math/polygonal_representations.pl)\n    * [Polynomial interpolation](./Math/polynomial_interpolation.pl)\n    * [Power divisors](./Math/power_divisors.pl)\n    * [Power of factorial ramanujan](./Math/power_of_factorial_ramanujan.pl)\n    * [Power unitary divisors](./Math/power_unitary_divisors.pl)\n    * [Powerfree divisors](./Math/powerfree_divisors.pl)\n    * [Powers of primes in factorial](./Math/powers_of_primes_in_factorial.pl)\n    * [Powers of primes modulus in factorial](./Math/powers_of_primes_modulus_in_factorial.pl)\n    * [Prime 41](./Math/prime_41.pl)\n    * [Prime abundant sequences](./Math/prime_abundant_sequences.pl)\n    * [Prime count smooth sum](./Math/prime_count_smooth_sum.pl)\n    * [Prime counting from almost primes](./Math/prime_counting_from_almost_primes.pl)\n    * [Prime counting from squarefree almost primes](./Math/prime_counting_from_squarefree_almost_primes.pl)\n    * [Prime counting liouville formula](./Math/prime_counting_liouville_formula.pl)\n    * [Prime counting mertens formula](./Math/prime_counting_mertens_formula.pl)\n    * [Prime factorization concept](./Math/prime_factorization_concept.pl)\n    * [Prime factors of binomial coefficients](./Math/prime_factors_of_binomial_coefficients.pl)\n    * [Prime factors of binomial product](./Math/prime_factors_of_binomial_product.pl)\n    * [Prime factors of factorial](./Math/prime_factors_of_factorial.pl)\n    * [Prime factors of superfactorial and hyperfactorial](./Math/prime_factors_of_superfactorial_and_hyperfactorial.pl)\n    * [Prime formulas](./Math/prime_formulas.pl)\n    * [Prime functions in terms of zeros of zeta](./Math/prime_functions_in_terms_of_zeros_of_zeta.pl)\n    * [Prime numbers generator](./Math/prime_numbers_generator.pl)\n    * [Prime omega function generalized](./Math/prime_omega_function_generalized.pl)\n    * [Prime quadratic polynomial analyzer](./Math/prime_quadratic_polynomial_analyzer.pl)\n    * [Prime quadratic polynomials](./Math/prime_quadratic_polynomials.pl)\n    * [Prime signature numbers in range](./Math/prime_signature_numbers_in_range.pl)\n    * [Prime summation](./Math/prime_summation.pl)\n    * [Prime zeta](./Math/prime_zeta.pl)\n    * [Primes diff](./Math/primes_diff.pl)\n    * [Primes sum of pair product](./Math/primes_sum_of_pair_product.pl)\n    * [Primitive sum of two squares](./Math/primitive_sum_of_two_squares.pl)\n    * [Primorial deflation](./Math/primorial_deflation.pl)\n    * [Pseudo square root](./Math/pseudo_square_root.pl)\n    * [PSW primality test](./Math/PSW_primality_test.pl)\n    * [PSW primality test mpz](./Math/PSW_primality_test_mpz.pl)\n    * [Pythagorean triples](./Math/pythagorean_triples.pl)\n    * [Quadratic-integer factorization method](./Math/quadratic-integer_factorization_method.pl)\n    * [Quadratic-integer factorization method mpz](./Math/quadratic-integer_factorization_method_mpz.pl)\n    * [Quadratic frobenius primality test](./Math/quadratic_frobenius_primality_test.pl)\n    * [Quadratic frobenius pseudoprimes generation](./Math/quadratic_frobenius_pseudoprimes_generation.pl)\n    * [Quadratic polynomial in terms of its zeros](./Math/quadratic_polynomial_in_terms_of_its_zeros.pl)\n    * [Ramanujan sum](./Math/ramanujan_sum.pl)\n    * [Ramanujan sum fast](./Math/ramanujan_sum_fast.pl)\n    * [Random carmichael fibonacci pseudoprimes](./Math/random_carmichael_fibonacci_pseudoprimes.pl)\n    * [Random integer factorization](./Math/random_integer_factorization.pl)\n    * [Random miller-rabin pseudoprimes](./Math/random_miller-rabin_pseudoprimes.pl)\n    * [Range map](./Math/range_map.pl)\n    * [Rational approximations](./Math/rational_approximations.pl)\n    * [Rational continued fractions](./Math/rational_continued_fractions.pl)\n    * [Rational prime product](./Math/rational_prime_product.pl)\n    * [Rational summation of fractions](./Math/rational_summation_of_fractions.pl)\n    * [Reciprocal cycle length](./Math/reciprocal_cycle_length.pl)\n    * [Rectangle sides from area and diagonal](./Math/rectangle_sides_from_area_and_diagonal.pl)\n    * [Rectangle sides from diagonal angles](./Math/rectangle_sides_from_diagonal_angles.pl)\n    * [Rectangle sides from one diagonal angle](./Math/rectangle_sides_from_one_diagonal_angle.pl)\n    * [Recursive matrix multiplication](./Math/recursive_matrix_multiplication.pl)\n    * [Rest calc](./Math/rest_calc.pl)\n    * [Reversed number triangle](./Math/reversed_number_triangle.pl)\n    * [Reversed number triangles](./Math/reversed_number_triangles.pl)\n    * [Riemann prime-counting function](./Math/riemann_prime-counting_function.pl)\n    * [Riemann's J function](./Math/riemann_s_J_function.pl)\n    * [Roots on the rise](./Math/roots_on_the_rise.pl)\n    * [RSA example](./Math/RSA_example.pl)\n    * [RSA PRNG](./Math/RSA_PRNG.pl)\n    * [Secant numbers](./Math/secant_numbers.pl)\n    * [Semiprime equationization](./Math/semiprime_equationization.pl)\n    * [Semiprime equationization uncached](./Math/semiprime_equationization_uncached.pl)\n    * [Sequence analyzer](./Math/sequence_analyzer.pl)\n    * [Sequence closed form](./Math/sequence_closed_form.pl)\n    * [Sequence polynomial closed form](./Math/sequence_polynomial_closed_form.pl)\n    * [Sieve of eratosthenes](./Math/sieve_of_eratosthenes.pl)\n    * [Sigma0 of factorial](./Math/sigma0_of_factorial.pl)\n    * [Sigma function](./Math/sigma_function.pl)\n    * [Sigma of factorial](./Math/sigma_of_factorial.pl)\n    * [Sigma of product of binomials](./Math/sigma_of_product_of_binomials.pl)\n    * [Sigma p adic](./Math/sigma_p_adic.pl)\n    * [Siqs factorization](./Math/siqs_factorization.pl)\n    * [Smallest carmichael divisible by n](./Math/smallest_carmichael_divisible_by_n.pl)\n    * [Smallest k-gonal inverse](./Math/smallest_k-gonal_inverse.pl)\n    * [Smallest k-gonal inverse brute force](./Math/smallest_k-gonal_inverse_brute_force.pl)\n    * [Smallest lucas-carmichael divisible by n](./Math/smallest_lucas-carmichael_divisible_by_n.pl)\n    * [Smallest number with at least n divisors](./Math/smallest_number_with_at_least_n_divisors.pl)\n    * [Smallest number with n divisors](./Math/smallest_number_with_n_divisors.pl)\n    * [Smarandache function](./Math/smarandache_function.pl)\n    * [Smooth numbers generalized](./Math/smooth_numbers_generalized.pl)\n    * [Solutions to x squared equals -1 mod n](./Math/solutions_to_x_squared_equals_-1_mod_n.pl)\n    * [Solutions to x squared equals 1 mod n](./Math/solutions_to_x_squared_equals_1_mod_n.pl)\n    * [Solutions to x squared equals a mod n](./Math/solutions_to_x_squared_equals_a_mod_n.pl)\n    * [Solve congruence equation example](./Math/solve_congruence_equation_example.pl)\n    * [Solve cubic equation](./Math/solve_cubic_equation.pl)\n    * [Solve cubic equation real](./Math/solve_cubic_equation_real.pl)\n    * [Solve modular cubic equation](./Math/solve_modular_cubic_equation.pl)\n    * [Solve modular quadratic equation](./Math/solve_modular_quadratic_equation.pl)\n    * [Solve pell equation](./Math/solve_pell_equation.pl)\n    * [Solve pell equation fast](./Math/solve_pell_equation_fast.pl)\n    * [Solve pell equation generalized](./Math/solve_pell_equation_generalized.pl)\n    * [Solve pell equation simple](./Math/solve_pell_equation_simple.pl)\n    * [Solve quadratic diophantine reciprocals](./Math/solve_quadratic_diophantine_reciprocals.pl)\n    * [Solve reciprocal pythagorean equation](./Math/solve_reciprocal_pythagorean_equation.pl)\n    * [Solve sequence](./Math/solve_sequence.pl)\n    * [Sophie germain factorization method](./Math/sophie_germain_factorization_method.pl)\n    * [Sorting algorithms](./Math/sorting_algorithms.pl)\n    * [Sphere volume](./Math/sphere_volume.pl)\n    * [Sqrt mod p tonelli-shanks mpz](./Math/sqrt_mod_p_tonelli-shanks_mpz.pl)\n    * [Square divisors](./Math/square_divisors.pl)\n    * [Square product subsets](./Math/square_product_subsets.pl)\n    * [Square root convergents](./Math/square_root_convergents.pl)\n    * [Square root method](./Math/square_root_method.pl)\n    * [Square root modulo n tonelli-shanks](./Math/square_root_modulo_n_tonelli-shanks.pl)\n    * [Squarefree almost prime divisors](./Math/squarefree_almost_prime_divisors.pl)\n    * [Squarefree almost primes from factor list](./Math/squarefree_almost_primes_from_factor_list.pl)\n    * [Squarefree almost primes in range](./Math/squarefree_almost_primes_in_range.pl)\n    * [Squarefree almost primes in range from factor list](./Math/squarefree_almost_primes_in_range_from_factor_list.pl)\n    * [Squarefree almost primes in range mpz](./Math/squarefree_almost_primes_in_range_mpz.pl)\n    * [Squarefree divisors](./Math/squarefree_divisors.pl)\n    * [Squarefree fermat overpseudoprimes in range](./Math/squarefree_fermat_overpseudoprimes_in_range.pl)\n    * [Squarefree fermat pseudoprimes in range](./Math/squarefree_fermat_pseudoprimes_in_range.pl)\n    * [Squarefree fermat pseudoprimes in range mpz](./Math/squarefree_fermat_pseudoprimes_in_range_mpz.pl)\n    * [Squarefree lucas U pseudoprimes in range](./Math/squarefree_lucas_U_pseudoprimes_in_range.pl)\n    * [Squarefree strong fermat pseudoprimes in range](./Math/squarefree_strong_fermat_pseudoprimes_in_range.pl)\n    * [Squarefree strong fermat pseudoprimes in range mpz](./Math/squarefree_strong_fermat_pseudoprimes_in_range_mpz.pl)\n    * [Squarefree strong fermat pseudoprimes to multiple bases in range](./Math/squarefree_strong_fermat_pseudoprimes_to_multiple_bases_in_range.pl)\n    * [Squarefree strong fermat pseudoprimes to multiple bases in range mpz](./Math/squarefree_strong_fermat_pseudoprimes_to_multiple_bases_in_range_mpz.pl)\n    * [Stern brocot encoding](./Math/stern_brocot_encoding.pl)\n    * [Stern brocot sequence](./Math/stern_brocot_sequence.pl)\n    * [Strong fermat pseudoprimes in range](./Math/strong_fermat_pseudoprimes_in_range.pl)\n    * [Strong fermat pseudoprimes in range mpz](./Math/strong_fermat_pseudoprimes_in_range_mpz.pl)\n    * [Sub-unit squares](./Math/sub-unit_squares.pl)\n    * [Sum factorial](./Math/sum_factorial.pl)\n    * [Sum of an even number of positive squares](./Math/sum_of_an_even_number_of_positive_squares.pl)\n    * [Sum of digits](./Math/sum_of_digits.pl)\n    * [Sum of digits subquadratic algorithm](./Math/sum_of_digits_subquadratic_algorithm.pl)\n    * [Sum of digits subquadratic algorithm mpz](./Math/sum_of_digits_subquadratic_algorithm_mpz.pl)\n    * [Sum of k-powerful numbers in range](./Math/sum_of_k-powerful_numbers_in_range.pl)\n    * [Sum of natural powers in constant base](./Math/sum_of_natural_powers_in_constant_base.pl)\n    * [Sum of perfect powers](./Math/sum_of_perfect_powers.pl)\n    * [Sum of prime-power exponents of factorial](./Math/sum_of_prime-power_exponents_of_factorial.pl)\n    * [Sum of prime-power exponents of product of binomials](./Math/sum_of_prime-power_exponents_of_product_of_binomials.pl)\n    * [Sum of prime powers](./Math/sum_of_prime_powers.pl)\n    * [Sum of primes generalized](./Math/sum_of_primes_generalized.pl)\n    * [Sum of sigma](./Math/sum_of_sigma.pl)\n    * [Sum of sigma 2](./Math/sum_of_sigma_2.pl)\n    * [Sum of the number of divisors](./Math/sum_of_the_number_of_divisors.pl)\n    * [Sum of the number of divisors of gcd x y](./Math/sum_of_the_number_of_divisors_of_gcd_x_y.pl)\n    * [Sum of the number of unitary divisors](./Math/sum_of_the_number_of_unitary_divisors.pl)\n    * [Sum of the sum of divisors](./Math/sum_of_the_sum_of_divisors.pl)\n    * [Sum of three cubes problem](./Math/sum_of_three_cubes_problem.pl)\n    * [Sum of triangular numbers solutions](./Math/sum_of_triangular_numbers_solutions.pl)\n    * [Sum of two primes](./Math/sum_of_two_primes.pl)\n    * [Sum of two squares all solutions](./Math/sum_of_two_squares_all_solutions.pl)\n    * [Sum of two squares all solutions 2](./Math/sum_of_two_squares_all_solutions_2.pl)\n    * [Sum of two squares all solutions tonelli-shanks](./Math/sum_of_two_squares_all_solutions_tonelli-shanks.pl)\n    * [Sum of two squares multiple solutions](./Math/sum_of_two_squares_multiple_solutions.pl)\n    * [Sum of two squares solution](./Math/sum_of_two_squares_solution.pl)\n    * [Sum remainders](./Math/sum_remainders.pl)\n    * [Super pandigital numbers](./Math/super_pandigital_numbers.pl)\n    * [Tangent numbers](./Math/tangent_numbers.pl)\n    * [Trial division fast](./Math/trial_division_fast.pl)\n    * [Triangle hyperoperation](./Math/triangle_hyperoperation.pl)\n    * [Triangle interior angles](./Math/triangle_interior_angles.pl)\n    * [Tribonacci primality test](./Math/tribonacci_primality_test.pl)\n    * [Trip2mars](./Math/trip2mars.pl)\n    * [Unique permutations](./Math/unique_permutations.pl)\n    * [Unitary divisors](./Math/unitary_divisors.pl)\n    * [Unitary divisors fast](./Math/unitary_divisors_fast.pl)\n    * [Unitary squarefree divisors](./Math/unitary_squarefree_divisors.pl)\n    * [Wilson prime formula](./Math/wilson_prime_formula.pl)\n    * [Yahtzee](./Math/yahtzee.pl)\n    * [Zequals](./Math/zequals.pl)\n    * [Zeta 2n](./Math/zeta_2n.pl)\n    * [Zeta for primes](./Math/zeta_for_primes.pl)\n    * [Zeta function](./Math/zeta_function.pl)\n    * [Zeta prime count approx](./Math/zeta_prime_count_approx.pl)\n* Media\n    * [Wimp-viewer](./Media/wimp-viewer)\n* Microphone\n    * Alsa\n        * [Raw from microphone](./Microphone/Alsa/raw_from_microphone.pl)\n    * Julius\n        * [Julius voice control concept](./Microphone/Julius/julius_voice_control_concept.pl)\n        * [Voice control](./Microphone/Julius/voice_control.pl)\n* Monitoring\n    * [File-monitor](./Monitoring/file-monitor)\n* Other\n    * [Concatenation weirdness](./Other/concatenation_weirdness.pl)\n    * [Lexical subs recursion bug](./Other/lexical_subs_recursion_bug.pl)\n    * [Tail recursion](./Other/tail_recursion.pl)\n    * [Yafu factorization](./Other/yafu_factorization.pl)\n* Regex\n    * [Positive-negative matching](./Regex/positive-negative_matching.pl)\n    * [Prime regexp](./Regex/prime_regexp.pl)\n    * [Regex optimizer in source](./Regex/regex_optimizer_in_source.pl)\n    * [Regex pair factors](./Regex/regex_pair_factors.pl)\n    * [Regexp to strings](./Regex/regexp_to_strings.pl)\n* Search\n    * [Binary search](./Search/binary_search.pl)\n    * [Binary search ge](./Search/binary_search_ge.pl)\n    * [Binary search le](./Search/binary_search_le.pl)\n* Shell\n    * [Execute perl scripts](./Shell/execute_perl_scripts.pl)\n* Simulation\n    * [100 prisoners riddle](./Simulation/100_prisoners_riddle.pl)\n* Socket\n    * [Chat server](./Socket/chat_server.pl)\n* Sort\n    * [Binsertion sorting algorithm](./Sort/binsertion_sorting_algorithm.pl)\n    * [Dream sort](./Sort/dream_sort.pl)\n* Subtitle\n    * [Srt-delay](./Subtitle/srt-delay)\n    * [Srt assembler](./Subtitle/srt_assembler.pl)\n    * [Srt fix](./Subtitle/srt_fix.pl)\n* Text\n    * [Abs string](./Text/abs_string.pl)\n    * [All substrings](./Text/all_substrings.pl)\n    * [Change-encoding](./Text/change-encoding.pl)\n    * [Group alike words](./Text/group_alike_words.pl)\n    * [Jaro-winkler distance](./Text/jaro-winkler_distance.pl)\n    * [Levenshtein distance iter](./Text/levenshtein_distance_iter.pl)\n    * [Levenshtein distance rec](./Text/levenshtein_distance_rec.pl)\n    * [Markov chain text generator](./Text/markov_chain_text_generator.pl)\n    * [Orthogonal text scrambling](./Text/orthogonal_text_scrambling.pl)\n    * [Orthogonal text scrambling double](./Text/orthogonal_text_scrambling_double.pl)\n    * [Repeated substrings](./Text/repeated_substrings.pl)\n    * [Search by prefix](./Text/search_by_prefix.pl)\n    * [Sim end words](./Text/sim_end_words.pl)\n    * [SmartWordWrap](./Text/smartWordWrap.pl)\n    * [SmartWordWrap lazy](./Text/smartWordWrap_lazy.pl)\n    * [SmartWordWrap simple](./Text/smartWordWrap_simple.pl)\n    * [Unique prefixes](./Text/unique_prefixes.pl)\n    * [Word roots](./Text/word_roots.pl)\n    * [Word unscrambler](./Text/word_unscrambler.pl)\n* Time\n    * [Calendar](./Time/calendar.pl)\n    * [Contdown](./Time/contdown.pl)\n* Video\n    * [Sponsor-free](./Video/sponsor-free.pl)\n    * [Video concat ffmpeg](./Video/video_concat_ffmpeg.pl)\n    * [Video split ffmpeg](./Video/video_split_ffmpeg.pl)\n* Visualisators\n    * [Binview](./Visualisators/binview.pl)\n    * [Disk-stats](./Visualisators/disk-stats.pl)\n    * [Dnscrypt stats](./Visualisators/dnscrypt_stats.pl)\n    * [Greycmd](./Visualisators/greycmd.pl)\n    * [Human-finder-visual](./Visualisators/human-finder-visual.pl)\n    * [Lz visual](./Visualisators/lz_visual.pl)\n    * [Matrix path 2-ways best](./Visualisators/matrix_path_2-ways_best.pl)\n    * [Matrix path 3-ways best](./Visualisators/matrix_path_3-ways_best.pl)\n    * [Matrix path 3-ways greedy](./Visualisators/matrix_path_3-ways_greedy.pl)\n    * [Pview](./Visualisators/pview)\n    * [Random finder visual](./Visualisators/random_finder_visual.pl)\n    * [Triangle sub-string finder](./Visualisators/triangle_sub-string_finder.pl)\n    * [Visual lz77 compression](./Visualisators/visual_lz77_compression.pl)\n    * [Visual sudoku dice solver](./Visualisators/visual_sudoku_dice_solver.pl)\n"
  },
  {
    "path": "Regex/positive-negative_matching.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 30 May 2013\n# https://github.com/trizen\n\n# Returns true in a positive check\n# if a string doesn't matches a regex.\n\nmy $string = 'This is a TOP 10 string.';\n\nif ($string =~ m{^(?(?{/top/i})(?!))}) {\n    print \"Doesn't contains the 'top' word.\\n\";\n}\nelse {\n    print \"Contains the 'top' word.\\n\";\n}\n"
  },
  {
    "path": "Regex/prime_regexp.pl",
    "content": "#!/usr/bin/perl\n\n$\\ = \"\\n\";\nmy $prime = 0;\nmy $limit = shift() || 100;\n\nwhile ($prime++ < $limit) {\n    $_ .= 0;\n\n    print $prime if $prime > 1 and not /^(00+?)\\1+$/;\n\n    # How it works?\n    # When length(${^MATCH}) is not equal to length($_), then is a prime number\n    # Uncomment the following lines to see how it actually works...\n\n#    if(/^(00+?)\\1+$/p){\n#        print \"number = $prime\\ndolar1 = $1 (\",length($1),\")\\n\\$& = $& (\",length(${^MATCH}),\")\\n\\$_ = $_ (\",length($_),\")\\n\\n\";\n#    }elsif(!/^(00+?)\\1+$/p){\n#        print \"number = $prime\\ndolar1 = $1 (\",length($1),\")\\n\\$& = $& (\",length(${^MATCH}),\")\\n\\$_ = $_ (\",length($_),\")\\n\\n\";\n#    }\n\n}\n"
  },
  {
    "path": "Regex/regex_optimizer_in_source.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 12 November 2017\n# https://github.com/trizen\n\n# Optimize regular expressions in a given Perl source code, using Perl::Tokenizer and Regexp::Optimizer.\n\n# Example:\n#   qr/foobar|fooxar|foozap$/im  -> qr/foo(?:[bx]ar|zap$)/im\n#    m/foobar|fooxar|foozap$/gci ->   /foo(?:[bx]ar|zap$)/cgi\n\n# Regexes which (potentially) include variable interpolation, are ignored.\n\n# The input source code must be UTF-8 encoded.\n\nuse utf8;\nuse 5.018;\nuse warnings;\n\nuse open IO => ':encoding(UTF-8)', ':std';\n\nuse Regexp::Optimizer;\nuse Data::Dump qw(pp);\nuse Perl::Tokenizer qw(perl_tokens);\nuse Encode qw(decode_utf8 encode_utf8);\n\n# usage: perl script.pl < source.pl\nmy $code = join('', <>);\n\nmy $regexp_optimizer = Regexp::Optimizer->new;\n\nperl_tokens {\n    my ($name, $i, $j) = @_;\n\n    if (   $name eq 'match_regex'\n        or $name eq 'compiled_regex') {\n\n        my $str = substr($code, $i, $j - $i);\n\n        my @flags;\n\n        if ($name eq 'match_regex') {\n\n            $str =~ s/^m//;\n            $str = 'qr' . $str;\n\n            if ($str =~ s/^.*\\Kg([a-z]*)\\z/$1/s) {\n                push @flags, 'g';\n            }\n\n            if ($str =~ s/^.*\\Kc([a-z]*)\\z/$1/s) {\n                push @flags, 'c';\n            }\n        }\n\n        my $eval_code = join(\n                             ';',\n                             'my $str = qq{' . quotemeta(encode_utf8($str)) . '}',    # quoted string\n                             'die if $str =~ /[\\$\\@][{\\\\w]/',                         # skip regexes with interpolation\n                             '$str = eval $str',                                      # evaluate string\n                             'die if $@',                                             # check the status of eval()\n                             '$str',                                                  # regex ref\n                            );\n\n        my $raw_str = eval($eval_code);\n\n        if (defined($raw_str) and !$@) {\n\n            my $regex_str = eval { decode_utf8(pp($regexp_optimizer->optimize($raw_str))) };\n\n            if (defined($regex_str)) {\n\n                my ($delim_beg, $delim_end);\n\n                if ($regex_str =~ /^qr(.)\\(\\?\\^([a-z]+):(.*)\\)(.)\\z/s) {\n                    ($delim_beg, $regex_str, $delim_end) = ($1, $3, $4);\n                    push @flags, split(//, $2);\n                }\n\n#<<<\n                $regex_str = join('',\n                    $delim_beg, $regex_str, $delim_end,\n                        (sort { $a cmp $b } grep { $_ ne 'u' } @flags)\n                );\n#>>>\n\n                if ($name eq 'match_regex') {\n                    $regex_str = 'm' . $regex_str if ($regex_str !~ m{^/});\n                }\n                else {\n                    $regex_str = 'qr' . $regex_str;\n                }\n\n                print $regex_str;\n                return;\n            }\n        }\n    }\n\n    print substr($code, $i, $j - $i);\n} $code;\n"
  },
  {
    "path": "Regex/regex_pair_factors.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 14 April 2014\n# Website: https://github.com/trizen\n\n# Get the pair factors for a number (using a regex)\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nmy $prod = $ARGV[0] // 36;\nmy $msg  = 'a' x $prod;\n\nfor my $i (2 .. $prod / 2) {\n    for my $j ($i .. $prod / $i) {\n        if ($msg =~ /^(?:a{$i}){$j}\\z/) {\n            say \"$j * $i == $prod\";\n        }\n    }\n}\n"
  },
  {
    "path": "Regex/regexp_to_strings.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 21 December 2014\n# Website: https://github.com/trizen\n\n# Find the minimum sentence(s) that satisfies a regular expression\n# See also: https://www.perlmonks.org/?node_id=284513\n\n# WARNING: this script is just an idea in development\n\n# usage: perl regex_to_strings.pl [regexp]\n\nuse utf8;\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Regexp::Parser;\nuse Data::Dump qw(pp);\n\nbinmode(STDOUT, ':utf8');\n\n{\n    no warnings 'redefine';\n    *Regexp::Parser::anyof_class::new = sub {\n        my ($class, $rx, $type, $neg, $how) = @_;\n        my $self = bless {\n                          rx     => $rx,\n                          flags  => $rx->{flags}[-1],\n                          family => 'anyof_class',\n                         }, $class;\n\n        if (ref $type) {\n            $self->{data} = $type;\n        }\n        else {\n            $self->{type} = $type;\n            $self->{data} = 'POSIX';\n            $self->{neg}  = $neg;\n            $self->{how}  = ${$how};    # bug-fix\n        }\n\n        return $self;\n    };\n}\n\nmy $regex = shift() // 'ab(c[12]|d(n|p)o)\\w{3}[.?!]{4}';\nmy $parser = Regexp::Parser->new($regex);\n\nmy %conv = (\n            alnum  => 'a',\n            nalnum => '#',\n            digit  => '1',\n            ndigit => '+',\n            space  => ' ',\n            nspace => '.',\n           );\n\nmy @stack;\nmy @strings = [];\nmy $ref     = \\@strings;\n\nmy $iter = $parser->walker;\n\nmy $min        = 1;\nmy $last_depth = 0;\nwhile (my ($node, $depth) = $iter->()) {\n\n    my $family = $node->family;\n    my $type   = $node->type;\n\n    if ($depth < $last_depth) {\n        $min = 1;\n        say \"MIN CHANGED\";\n    }\n\n    if ($family eq 'quant') {\n        $min = $node->min;\n        say \"MIN == $min\";\n    }\n\n    pp $family, $type, $node->qr;    # for debug\n\n    if ($type =~ /^(?:close\\d|tail)/) {\n        $ref = pop @stack;\n    }\n    elsif (exists $conv{$type}) {\n        push @{$ref->[-1]}, $conv{$type} x $min;\n    }\n    elsif ($family eq 'open' or $type eq 'group' or $type eq 'suspend') {\n        push @stack, $ref;\n        push @{$ref->[-1]}, [];\n        $ref = $ref->[-1][-1];\n        push @{$ref}, [];\n    }\n    elsif ($type eq 'branch') {\n        $#{$ref->[-1]} == -1 or push @{$ref}, [];\n    }\n    elsif ($type eq 'exact' or $type eq 'exactf') {\n        push @{$ref->[-1]}, $node->data x $min;\n    }\n    elsif ($type eq 'anyof' and $min > 0) {\n        my $regex = $node->qr;\n        foreach my $c (0 .. 1000000) {\n            if (chr($c) =~ /$regex/) {\n                push @{$ref->[-1]}, chr($c) x $min;\n                last;\n            }\n        }\n    }\n\n    $last_depth = $depth;\n}\n\nuse Data::Dump qw(pp);\npp @strings;\n\n# TODO: join the @strings into real $strings\n"
  },
  {
    "path": "Search/binary_search.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 10 July 2019\n# https://github.com/trizen\n\n# The binary search algorithm.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Binary_search_algorithm\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nsub bsearch ($left, $right, $callback) {\n\n    while ($left <= $right) {\n\n        my $mid = int(($left + $right) / 2);\n        my $cmp = $callback->($mid) || return $mid;\n\n        if ($cmp > 0) {\n            $right = $mid - 1;\n        }\n        else {\n            $left = $mid + 1;\n        }\n    }\n\n    return undef;\n}\n\nsay bsearch(0, 202,  sub ($x) { $x * $x <=> 49 });     #=> 7   (7*7  = 49)\nsay bsearch(3, 1000, sub ($x) { $x**$x <=> 3125 });    #=> 5   (5**5 = 3125)\n"
  },
  {
    "path": "Search/binary_search_ge.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 10 July 2019\n# https://github.com/trizen\n\n# The binary search algorithm: \"greater than or equal to\" variation.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Binary_search_algorithm\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nsub bsearch_ge ($left, $right, $callback) {\n\n    my ($mid, $cmp);\n\n    for (; ;) {\n\n        $mid = int(($left + $right) / 2);\n        $cmp = $callback->($mid) || return $mid;\n\n        if ($cmp < 0) {\n            $left = $mid + 1;\n\n            if ($left > $right) {\n                $mid += 1;\n                last;\n            }\n        }\n        else {\n            $right = $mid - 1;\n            $left > $right and last;\n        }\n    }\n\n    return $mid;\n}\n\nsay bsearch_ge(0, 202,  sub ($x) { $x * $x <=> 49 });     #=> 7   (7*7  = 49)\nsay bsearch_ge(3, 1000, sub ($x) { $x**$x <=> 3125 });    #=> 5   (5**5 = 3125)\n\nsay bsearch_ge(1,    1e6, sub ($x) { exp($x) <=> 1e+9 }); #=>  21   (exp( 21) >= 1e+9)\nsay bsearch_ge(-1e6, 1e6, sub ($x) { exp($x) <=> 1e-9 }); #=> -20   (exp(-20) >= 1e-9)\n"
  },
  {
    "path": "Search/binary_search_le.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 10 July 2019\n# https://github.com/trizen\n\n# The binary search algorithm: \"less than or equal to\" variation.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Binary_search_algorithm\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\nsub bsearch_le ($left, $right, $callback) {\n\n    my ($mid, $cmp);\n\n    for (; ;) {\n\n        $mid = int(($left + $right) / 2);\n        $cmp = $callback->($mid) || return $mid;\n\n        if ($cmp < 0) {\n            $left = $mid + 1;\n            $left > $right and last;\n        }\n        else {\n            $right = $mid - 1;\n\n            if ($left > $right) {\n                $mid -= 1;\n                last;\n            }\n        }\n    }\n\n    return $mid;\n}\n\nsay bsearch_le(0, 202,  sub ($x) { $x * $x <=> 49 });     #=> 7   (7*7  = 49)\nsay bsearch_le(3, 1000, sub ($x) { $x**$x <=> 3125 });    #=> 5   (5**5 = 3125)\n\nsay bsearch_le(1,    1e6, sub ($x) { exp($x) <=> 1e+9 }); #=>  20   (exp( 20) <= 1e+9)\nsay bsearch_le(-1e6, 1e6, sub ($x) { exp($x) <=> 1e-9 }); #=> -21   (exp(-21) <= 1e-9)\n"
  },
  {
    "path": "Shell/execute_perl_scripts.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 25 June 2024\n# https://github.com/trizen\n\n# Execute a given list of Perl scripts given as command-line arguments.\n\nuse 5.036;\n\nuse File::Basename qw(basename);\nuse Getopt::Long   qw(GetOptions);\n\nmy $arg   = undef;\nmy $regex = undef;\n\nsub usage($exit_code = 0) {\n    print <<\"EOT\";\nusage: $0 [options] [Perl scripts]\n\noptions:\n\n    --regex=s : execute scripts matching a given regex (default: None)\n    --arg=s   : an argument to be passed to each script (default: None)\n    --help    : print this message and exit\n\nexamples:\n\n    perl $0 --arg=42 *.pl\n    perl $0 --arg=42 --regex='^\\\\w+\\.pl\\\\z'\n\nEOT\n\n    exit($exit_code);\n}\n\nGetOptions(\n           'arg=s'   => \\$arg,\n           'regex=s' => \\$regex,\n           'h|help'  => sub { usage(0) },\n          )\n  or die(\"Error in command line arguments\\n\");\n\nmy @files = @ARGV;\n\nif (defined($regex)) {\n    my $re = qr{$regex};\n    foreach my $file (glob(\"*\")) {\n        if (basename($file) =~ $re) {\n            push @files, $file;\n        }\n    }\n}\n\n@files || usage(2);\n\nforeach my $script (@files) {\n\n    if (not -f $script) {\n        warn \"[!] Not a file: $script\\n. Skipping...\";\n    }\n\n    warn \":: Executing: $script\\n\";\n    system($^X, $script, (defined($arg) ? $arg : ()));\n    $? == 0 or die \"[!] Stopping... Exit code: $?\\n\";\n}\n"
  },
  {
    "path": "Simulation/100_prisoners_riddle.pl",
    "content": "#!/usr/bin/perl\n\n# Simulation of the 100 Prisoners Riddle.\n\n# See also the Veritasium video on this problem:\n#   https://yewtu.be/watch?v=iSNsgj1OCLA\n\nuse 5.014;\nuse strict;\nuse warnings;\n\nuse List::Util qw(shuffle);\n\nmy $ok        = 0;\nmy $runs      = 10000;\nmy $prisoners = 100;\n\nfor my $n (1 .. $runs) {\n\n    my @boxes = shuffle(0 .. $prisoners - 1);\n\n    my $success = 1;\n\n    foreach my $k (0 .. $prisoners - 1) {\n\n        my $found = 0;\n        my $pick  = $boxes[$k];\n\n        for (my $tries = $prisoners >> 1 ; $tries > 0 ; --$tries) {\n            if ($pick == $k) {\n                $found = 1;\n                last;\n            }\n            $pick = $boxes[$pick];\n        }\n\n        if (not $found) {\n            $success = 0;\n            last;\n        }\n    }\n\n    if ($success) {\n        ++$ok;\n    }\n}\n\nsay \"Probability of success: \", ($ok / $runs * 100), '%';\n\n__END__\nProbability of success: 31.52%\n"
  },
  {
    "path": "Socket/chat_server.pl",
    "content": "#!/usr/bin/perl\n\n#\n## Translation of: https://rosettacode.org/wiki/Chat_server#Python\n#\n\n# Create server:\n#     perl chat_server.pl\n\n# Connect to the chat via telnet:\n#     telnet localhost 4004\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse threads;\nuse threads::shared;\n\nuse IO::Socket::INET;\nuse Time::HiRes qw(sleep ualarm);\n\nmy $HOST = \"localhost\";\nmy $PORT = 4004;\n\nmy @open;\nmy %users : shared;\n\nsub broadcast {\n    my ($id, $message) = @_;\n    print \"$message\\n\";\n    foreach my $i (keys %users) {\n        if ($i != $id) {\n            $open[$i]->send(\"$message\\n\");\n        }\n    }\n}\n\nsub sign_in {\n    my ($conn) = @_;\n\n    state $id = 0;\n\n    threads->new(\n        sub {\n            while (1) {\n                $conn->send(\"Please enter your name: \");\n                $conn->recv(my $name, 1024, 0);\n\n                if (defined $name) {\n                    $name = unpack('A*', $name);\n\n                    if (exists $users{$name}) {\n                        $conn->send(\"Name entered is already in use.\\n\");\n                    }\n                    elsif ($name ne '') {\n                        $users{$id} = $name;\n                        broadcast($id, \"+++ $name arrived +++\");\n                        last;\n                    }\n                }\n            }\n        }\n    );\n\n    ++$id;\n    push @open, $conn;\n}\n\nmy $server = IO::Socket::INET->new(\n                                   Timeout   => 0,\n                                   LocalPort => $PORT,\n                                   Proto     => \"tcp\",\n                                   LocalAddr => $HOST,\n                                   Blocking  => 0,\n                                   Listen    => 1,\n                                   Reuse     => 1,\n                                  );\n\nlocal $| = 1;\nprint \"Listening on $HOST:$PORT\\n\";\n\nwhile (1) {\n    my ($conn) = $server->accept;\n\n    if (defined($conn)) {\n        sign_in($conn);\n    }\n\n    foreach my $i (keys %users) {\n\n        my $conn = $open[$i];\n        my $message;\n\n        eval {\n            local $SIG{ALRM} = sub { die \"alarm\\n\" };\n            ualarm(500);\n            $conn->recv($message, 1024, 0);\n            ualarm(0);\n        };\n\n        if ($@ eq \"alarm\\n\") {\n            next;\n        }\n\n        if (defined($message)) {\n            if ($message ne '') {\n                $message = unpack('A*', $message);\n                broadcast($i, \"$users{$i}> $message\");\n            }\n            else {\n                broadcast($i, \"--- $users{$i} leaves ---\");\n                delete $users{$i};\n                undef $open[$i];\n            }\n        }\n    }\n\n    sleep(0.1);\n}\n"
  },
  {
    "path": "Sort/binsertion_sorting_algorithm.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 16 December 2013\n# Edit: 06 December 2023\n# https://github.com/trizen\n\n# Sorting algorithm: insertion sort + binary search = binsertion sort\n\nuse 5.036;\nuse strict;\nuse warnings;\n\nsub bsearch_ge ($left, $right, $callback) {\n\n    my ($mid, $cmp);\n\n    for (; ;) {\n\n        $mid = ($left + $right) >> 1;\n        $cmp = $callback->($mid) || return $mid;\n\n        if ($cmp < 0) {\n            $left = $mid + 1;\n\n            if ($left > $right) {\n                $mid += 1;\n                last;\n            }\n        }\n        else {\n            $right = $mid - 1;\n            $left > $right and last;\n        }\n    }\n\n    return $mid;\n}\n\nsub binsertion_sort {\n    my (@list) = @_;\n\n    foreach my $i (1 .. $#list) {\n        if ((my $k = $list[$i]) < $list[$i - 1]) {\n            splice(@list, $i, 1);\n            splice(@list, bsearch_ge(0, $i - 1, sub ($j) { $list[$j] <=> $k }), 0, $k);\n        }\n    }\n\n    return @list;\n}\n\n#\n## MAIN\n#\n\nuse List::Util qw(shuffle);\n\nmy @list = (shuffle((1 .. 100) x 2))[0 .. 50];\n\nsay \"Before: \", join(' ', @list);\nsay \"After:  \", join(' ', binsertion_sort(@list));\n\nmy @sorted = sort { $a <=> $b } @list;\n\njoin(' ', binsertion_sort(@list)) eq join(' ', @sorted)           or die \"error\";\njoin(' ', binsertion_sort(@sorted)) eq join(' ', @sorted)         or die \"error\";\njoin(' ', binsertion_sort(reverse @sorted)) eq join(' ', @sorted) or die \"error\";\n"
  },
  {
    "path": "Sort/dream_sort.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 19 August 2025\n# https://github.com/trizen\n\n# A recursive sorting algorithm for strings, based on a dream that I had, similar to Radix sort.\n\n# The running time of the algorithm is:\n#   O(n * len(s))\n# where `n` is the number of strings being sorted and `s` is the longest string in the array.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Radix_sort\n\nuse 5.036;\nuse List::Util qw(shuffle);\nuse Test::More tests => 20;\n\nsub dream_sort($arr, $i = 0) {\n\n    my @buckets;\n\n    foreach my $item (@$arr) {\n        my $byte = substr($item, $i, 1) // '';\n        if ($byte eq '') {\n            $byte = 0;\n        }\n        else {\n            $byte = ord($byte) + 1;\n        }\n        push @{$buckets[$byte]}, $item;\n    }\n\n    my @sorted;\n\n    if (defined($buckets[0])) {\n        push @sorted, @{$buckets[0]};\n    }\n\n    foreach my $k (1 .. $#buckets) {\n        my $entry = $buckets[$k];\n        if (defined($entry)) {\n            if (scalar(@$entry) == 1) {\n                push @sorted, $entry->[0];\n            }\n            else {\n                push @sorted, @{__SUB__->($entry, $i + 1)};\n            }\n        }\n    }\n\n    return \\@sorted;\n}\n\nsub sort_test($arr) {\n    my @sorted = sort @$arr;\n    is_deeply(dream_sort($arr),             \\@sorted);\n    is_deeply(dream_sort([reverse @$arr]),  \\@sorted);\n    is_deeply(dream_sort(\\@sorted),         \\@sorted);\n    is_deeply(dream_sort([shuffle(@$arr)]), \\@sorted);\n}\n\nsort_test([\"abc\",  \"abd\"]);\nsort_test([\"abc\",  \"abc\"]);\nsort_test([\"abcd\", \"abc\"]);\nsort_test([\"John\", \"Kate\", \"Zerg\", \"Alice\", \"Joe\", \"Jane\"]);\n\nsort_test(\n    do {\n        open my $fh, '<:raw', __FILE__;\n        local $/;\n        [split(' ', scalar <$fh>)];\n    }\n);\n"
  },
  {
    "path": "Subtitle/srt-delay",
    "content": "#!/usr/bin/perl\n\n# Copyright (C) 2011-2017 Daniel \"Trizen\" Șuteu\n#\n# This program is free software: you can redistribute it and/or modify\n# it under the terms of the GNU General Public License as published by\n# the Free Software Foundation, either version 3 of the License, or\n# (at your option) any later version.\n#\n# This program is distributed in the hope that it will be useful,\n# but WITHOUT ANY WARRANTY; without even the implied warranty of\n# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n# GNU General Public License for more details.\n#\n# You should have received a copy of the GNU General Public License\n# along with this program.  If not, see <https://www.gnu.org/licenses/>.\n#\n#-------------------------------------------------------\n#  Appname: srt-delay\n#  Version: 0.0.6\n#  Created: 26 December 2011\n#  Edit on: 19 October 2020\n#  https://github.com/trizen\n#-------------------------------------------------------\n\nuse 5.014;\nuse strict;\nuse warnings;\n\nuse Getopt::Long qw(GetOptions);\n\nsub usage {\n    my ($exit_code) = @_;\n    print <<\"USAGE\";\nusage: $0 [options] [seconds] [file.srt]\n\nOptions:\n    -b  --backup    : backup original to .bak\n    -d  --delay=f   : number of seconds of delay\n    -s  --scale=f   : scale the timestamps by a multiple\n\nExamples: $0 -b -d=1.439 file.srt\n          $0 -b -d=0.321 file.srt\n          $0 -b -d=-3.14 file.srt\nUSAGE\n    exit($exit_code // 0);\n}\n\nsub time2sec {\n    my @out;\n    foreach my $time (@_) {\n        my ($hours, $min, $sec, $milisec) = split(/[:,]/, $time, 4);\n        push @out, $hours * 3600 + $min * 60 + $sec + $milisec / 1000;\n    }\n    return @out;\n}\n\nsub sec2time {\n    my @out;\n    foreach my $sec (map { sprintf '%.3f', $_ } @_) {\n        push @out,\n          sprintf('%02d:%02d:%02d,%03d', ($sec / 3600 % 24, $sec / 60 % 60, $sec % 60, substr($sec, index($sec, '.') + 1)));\n    }\n    return @out;\n}\n\nmy $delay  = 0;\nmy $backup = 0;\nmy $scale  = 1;\n\nGetOptions(\n           \"b|backup!\" => \\$backup,\n           \"s|scale=f\" => \\$scale,\n           \"d|delay=f\" => \\$delay,\n           \"h|help\"    => sub { usage(0) },\n          )\n  or die(\"Error in command line arguments\");\n\nmy @files = grep { -f $_ } @ARGV;\n\n@files || usage(2);\n\nforeach my $file (@files) {\n    my @output;\n    open my $fh, '<', $file or die \"Unable to open for read ${file}: $!\\n\";\n    while (defined(my $line = <$fh>)) {\n        if ($line =~ /^\\d+:\\d+:\\d+(?:,\\d+)?\\s*-->\\s*\\d+:\\d+:\\d+(?:,\\d+)?(\\s*)\\z/) {\n            push @output, join(\n                ' --> ',\n                sec2time(\n                    map {\n                        my $sec = $scale * $_ + $delay;\n                        ($sec >= 0)\n                          ? $sec\n                          : !warn \"[!] Time cannot be lower than zero at line $.\\n\";\n                    } time2sec(split(/\\s*-->\\s*/, $line, 2))\n                )\n              )\n              . $1;\n        }\n        else { push @output, $line }\n    }\n\n    close $fh;\n    rename $file, \"$file.bak\" if $backup;\n\n    open $fh, '>', $file or die \"Unable to open for write ${file}: $!\\n\";\n    print {$fh} @output;\n    close $fh;\n}\n"
  },
  {
    "path": "Subtitle/srt_assembler.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 14 December 2014\n# Edit: 14 December 2016\n# License: GPLv3\n# https://github.com/trizen\n\n# Extract the text and the skeleton from a SRT file.\n\n# The text can be translated into another language, then\n# joined back with the SRT skeleton into a new SRT file.\n\nuse utf8;\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse experimental qw(signatures);\n\nuse Getopt::Std qw(getopts);\nuse File::BOM qw(get_encoding_from_filehandle);\n\nsub usage {\n    my ($code) = @_;\n    require File::Basename;\n    my $main = File::Basename::basename($0);\n    print <<\"EOF\";\nusage: $main [options] [input file]\n\noptions:\n    -j  : join text with template\n    -t  : name of the template file\n\nexample:\n    $main -t file.t file.srt > file.text\n    $main -t file.t file.text > new_file.srt\nEOF\n\n    exit($code // 0);\n}\n\nsub prepare_words ($words, $width, $callback, $depth = 0) {\n\n    my @root;\n    my $len = 0;\n    my $i   = -1;\n\n    my $limit = $#{$words};\n    while (++$i <= $limit) {\n        $len += (my $word_len = length($words->[$i]));\n\n        if ($len > $width) {\n            if ($word_len > $width) {\n                $len -= $word_len;\n                splice(@$words, $i, 1, unpack(\"(A$width)*\", $words->[$i]));\n                $limit = $#{$words};\n                --$i;\n                next;\n            }\n            last;\n        }\n\n#<<<\n        push @root, [\n            join(' ', @{$words}[0 .. $i]),\n            prepare_words([@{$words}[$i + 1 .. $limit]], $width, $callback, $depth + 1),\n        ];\n#>>>\n\n        if ($depth == 0) {\n            $callback->($root[0]);\n            @root = ();\n        }\n\n        last if (++$len > $width);\n    }\n\n    \\@root;\n}\n\nsub combine ($path, $callback, $root = []) {\n    my $key = shift(@$path);\n    foreach my $value (@$path) {\n        push @$root, $key;\n        if (@$value) {\n            foreach my $item (@$value) {\n                combine($item, $callback, $root);\n            }\n        }\n        else {\n            $callback->($root);\n        }\n        pop @$root;\n    }\n}\n\nsub smart_wrap ($text, $width) {\n\n    my @words = (\n                 ref($text) eq 'ARRAY'\n                 ? @{$text}\n                 : split(' ', $text)\n                );\n\n    my %best = (\n                score => 'inf',\n                value => [],\n               );\n\n    prepare_words(\n        \\@words,\n        $width,\n        sub ($path) {\n            combine(\n                $path,\n                sub ($combination) {\n                    my $score = 0;\n                    foreach my $line (@$combination) {\n                        $score += ($width - length($line))**2;\n                        return if $score >= $best{score};\n                    }\n                    $best{score} = $score;\n                    $best{value} = [@$combination];\n                }\n            );\n        }\n    );\n\n    join(\"\\n\", @{$best{value}});\n}\n\nsub disassemble ($srt_file, $template_file) {\n\n    open(my $srt_fh,  '<:crlf', $srt_file);\n    open(my $tmpl_fh, '>',      $template_file);\n\n    my $enc = get_encoding_from_filehandle($srt_fh);\n\n    if (defined($enc) and $enc ne '') {\n        binmode($srt_fh, \":encoding($enc)\");\n        binmode(STDOUT,  \":encoding($enc)\");\n    }\n\n    local $/ = \"\";    # paragraph mode\n    while (defined(my $para = <$srt_fh>)) {\n        if (\n            $para =~ /^\n        (?<i>[0-9]+)\\h*\\R\n\n        (?<from>[0-9]{2}:[0-9]{2}:[0-9]{2},[0-9]{3})\n                     \\h*-->\\h*\n        (?<to>[0-9]{2}:[0-9]{2}:[0-9]{2},[0-9]{3})\\h*\\R\n\n        (?<text>.+)/sx\n          ) {\n            print {$tmpl_fh} \"$+{i}\\n$+{from} --> $+{to}\\n%s\\n\\n\";\n\n            my $text = $+{text};\n            $text =~ s/<.*?>//gs;    # remove HTML tags\n                                     # (consider this a bug)\n\n            print join(' ', split(' ', $text)), \"\\n\\n\";\n        }\n        else {\n            die \"[ERROR] Invalid paragraph:\n{{->>BEGIN<<-}}\n$para\n{{->>END<<-}}\\n\";\n        }\n    }\n\n    close $srt_fh;\n    close $tmpl_fh;\n}\n\nsub assemble ($text_file, $template_file) {\n\n    open my $txt_fh,  '<:crlf', $text_file;\n    open my $tmpl_fh, '<:crlf', $template_file;\n\n    my $enc = get_encoding_from_filehandle($txt_fh)\n      || get_encoding_from_filehandle($tmpl_fh);\n\n    if (defined($enc) and $enc ne '') {\n        binmode($txt_fh,  \":encoding($enc)\");\n        binmode($tmpl_fh, \":encoding($enc)\");\n        binmode(STDOUT,   \":encoding($enc)\");\n    }\n\n    local $/ = \"\";\n    while (defined(my $text = <$txt_fh>)) {\n        my $format = <$tmpl_fh> // die \"Unexpected error: template file is shorter than text!\";\n\n        $text =~ s/[?!.)\\]\"']\\K\\h+([-‒―—]+)(?=\\h)/\\n$1/g;\n        $text = join(\"\\n\", map { length($_) <= 45 ? $_ : smart_wrap($_, 45) } split(/\\R/, $text));\n\n        printf($format, $text);\n    }\n\n    close $txt_fh;\n    close $tmpl_fh;\n}\n\nmy %opt;\ngetopts('jt:h', \\%opt);\n\nmy $input_file    = shift(@ARGV) // usage(1);\nmy $template_file = $opt{t}      // ($input_file =~ s/\\.\\w{1,5}\\z//r . '.template');\n\n$opt{j} || ($input_file !~ /\\.srt\\z/)\n  ? assemble($input_file, $template_file)\n  : disassemble($input_file, $template_file);\n"
  },
  {
    "path": "Subtitle/srt_fix.pl",
    "content": "#!/usr/bin/perl\n\n# Fix subtitles translated with Google Translate\n\nuse strict;\nuse warnings;\n\nuse Tie::File;\n\nmy $filename = shift(@ARGV);\n\ntie my @lines, 'Tie::File', $filename\n  or die \"Can't tie into file `$filename': $!\";\n\nfor (@lines) {\n    s/(?<!-)->/-->/g;\n    /\\h-->\\h/\n      ? do {\n        s/[0-9]{2}\\K:\\h+(?=[0-9]{2})/:/g;\n      }\n      : do {\n        s{</\\K\\h+}{}g;\n        s{color\\K\\h*=\\h*#\\h*(?=[[:xdigit:]]{6})}{=#}g;\n      };\n}\n"
  },
  {
    "path": "Text/abs_string.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 24 March 2012\n# https://github.com/trizen\n\n# Expand a string to its absolute values\n\nuse strict;\nuse warnings;\nuse Data::Dumper;\n\nsub absolute_string ($) {\n    my @chunks = grep { defined && length } split(/([{}])|,/, shift);\n\n    my (@output, @root);\n    foreach my $i (0 .. $#chunks) {\n        if (defined $chunks[$i + 1] and $chunks[$i + 1] eq '{') {\n            push @root, $chunks[$i];\n        }\n        elsif ($chunks[$i] ne '{' and $chunks[$i] ne '}') {\n            push @output, join('', @root, $chunks[$i]);\n        }\n        if (defined $chunks[$i + 1] and $chunks[$i + 1] eq '}') {\n            pop @root;\n        }\n    }\n\n    return @output;\n}\n\nforeach my $x (\n               'perl-{gnome2-wnck,gtk2-{imageview,unique},x11-protocol,image-exiftool}',\n               'perl-{proc-{simple,processtable},net-{dbus,dropbox-api},goo-canvas}',\n               'perl-{sort-naturally,json,json-xs,xml-simple,www-mechanize,locale-gettext}',\n               'perl-{file-{which,basedir,copy-recursive},pathtools,path-class},mplayer'\n  ) {\n    print Dumper [absolute_string $x];\n}\n"
  },
  {
    "path": "Text/all_substrings.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 26 April 2015\n# website: https://github.com/trizen\n\n# Find all the possible substrings of a string. (creative solution)\n\nuse 5.012;\nuse strict;\nuse warnings;\n\nsub all_substrings {\n    my ($str, $callback) = @_;\n\n    my @cache;\n    my @chars = split(//, $str);\n    while (my ($i, $c) = each @chars) {\n        $cache[$_] .= $c for (0 .. $i);\n        $callback->(@cache);\n    }\n\n    return;\n}\n\nall_substrings(\"abcdefg\", sub { say for @_ });\n"
  },
  {
    "path": "Text/change-encoding.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 17 December 2023\n# https://github.com/trizen\n\n# Change the encoding of a text file.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Encode       qw(encode decode);\nuse Getopt::Long qw(GetOptions);\n\nmy $input_encoding  = 'iso-8859-2';\nmy $output_encoding = 'utf-8';\n\nsub help {\n    my ($exit_code) = @_;\n    $exit_code //= 0;\n    print <<\"EOT\";\nusage: $0 [options] [input.txt] [output.txt]\n\n    --from=s  : input encoding (default: $input_encoding)\n    --to=s    : output encoding (default: $output_encoding)\nEOT\n\n    exit($exit_code);\n}\n\nGetOptions(\n           \"from=s\" => \\$input_encoding,\n           \"to=s\"   => \\$output_encoding,\n           \"h|help\" => sub { help(0) }\n          )\n  or do {\n    warn(\"Error in command line arguments\\n\");\n    help(1);\n  };\n\nmy $input  = $ARGV[0] // help(1);\nmy $output = $ARGV[1] // $input;\n\nmy $raw = do {\n    open my $fh, '<:raw', $input or die \"Can't open <<$input>> for reading: $!\";\n    local $/;\n    <$fh>;\n};\n\nmy $dec = decode($input_encoding, $raw, Encode::FB_CROAK);\nmy $enc = encode($output_encoding, $dec, Encode::FB_CROAK);\n\nopen my $fh, '>:raw', $output or die \"Can't open <<$output>> for writing: $!\";\nprint $fh $enc;\nclose $fh;\n"
  },
  {
    "path": "Text/group_alike_words.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 20 July 2014\n# Website: https://github.com/trizen\n\n# Group in distinct paragraphs all the words that look pretty much the same to one another\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse open IO => ':utf8', ':std';\n\nuse POSIX qw(ceil);\nuse Getopt::Std qw(getopts);\nuse List::Util qw(first min);\n\nmy %opt = (d => 2);\n\nsub usage {\n    my ($code) = @_;\n\n    print <<\"USAGE\";\nusage: $0 [options] [input file]\n\noptions:\n        -d int  : the maximum distance between two words (default: $opt{d})\n        -m      : merge similar groups into one larger group\n        -k      : allow a word to exist in more than one group\n\n        -h      : print this message and exit\n\nexample:\n        $0 -d 1 input.txt > output.txt\nUSAGE\n\n    exit($code // 0);\n}\n\ngetopts('d:kmh', \\%opt);\n$opt{h} && usage();\n\n# Levenshtein's distance function (optimized for speed)\nsub leven {\n    my ($s, $t) = @_;\n\n    my @d = ([0 .. @$t], map { [$_] } 1 .. @$s);\n\n    foreach my $i (0 .. $#{$s}) {\n        foreach my $j (0 .. $#{$t}) {\n            $d[$i + 1][$j + 1] =\n              $s->[$i] eq $t->[$j]\n                ? $d[$i][$j]\n                : 1 + min($d[$i][$j + 1], $d[$i + 1][$j], $d[$i][$j]);\n        }\n    }\n\n    $d[-1][-1];\n}\n\n# When no file has been provided, throw an error\n@ARGV || usage(2);\n\n# Iterate over the argument-files\nforeach my $file (@ARGV) {\n\n    my @words = do {\n        my %w;\n        open my $fh, '<', $file or do {\n            warn \"Can't open file '$file': $!\";\n            next;\n        };\n        @w{map { unpack('A*') } <$fh>} = ();\n        map { [split //] } sort keys %w;\n    };\n\n    my %table;\n    for (my $i = 0 ; $i <= $#words - 1 ; $i++) {\n\n        printf STDERR \"[%*d of %d] Processing...\\r\", ceil(log(scalar @words) / log(10)), $i, scalar(@words);\n\n        my %h1;\n        @h1{@{$words[$i]}} = ();\n\n        for (my $j = $i + 1 ; $j <= $#words ; $j++) {\n\n            # If the lengths of the words differ by more than $opt{d}\n            if (abs(@{$words[$i]} - @{$words[$j]}) > $opt{d}) {\n                next;    # then there is no need to compute the distance\n            }\n\n            my %h2;\n            @h2{@{$words[$j]}} = ();\n\n            # One more check before calling the very\n            # expensive Levenshtein's distance function\n            my $diff = 0;\n            foreach my $key (keys %h1) {\n                exists $h2{$key} or do {\n                    last if ++$diff > $opt{d};\n                };\n            }\n\n            next if $diff > $opt{d};\n\n            # Compute the Levenshtein distance\n            if (leven($words[$i], $words[$j]) <= $opt{d}) {\n                if (not exists $table{$i}) {\n                    $table{$i} = [join('', @{$words[$i]})];\n                }\n                push @{$table{$i}}, join('', @{$words[$j]});\n                splice(@words, $j--, 1) if (not $opt{k} and not $opt{m});\n            }\n        }\n    }\n\n    # Clear the process line\n    print STDERR \"                             \\r\";\n\n    # Output the results\n    if ($opt{m}) {    # merge the groups\n        my @values = values %table;\n        for (my $i = 0 ; $i <= $#values ; $i++) {\n            foreach my $val (@{$values[$i]}) {\n                for (my $j = $i + 1 ; $j <= $#values ; $j++) {\n                    if (defined(first { $val eq $_ } @{$values[$j]})) {\n                        push @{$values[$i]}, @{$values[$j]};\n                        splice(@values, $j--, 1);\n                        last;\n                    }\n                }\n            }\n\n            my %w;\n            @w{@{$values[$i]}} = ();\n            say for sort keys %w;\n            print \"\\n\";\n        }\n    }\n    else {    # simple output\n        foreach my $value (values %table) {\n            say for @{$value};\n            print \"\\n\";\n        }\n    }\n}\n"
  },
  {
    "path": "Text/jaro-winkler_distance.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 17 October 2015\n# Website: https://github.com/trizen\n\n# Implementation of the Jaro-Winkler distance algorithm\n# See: https://en.wikipedia.org/wiki/Jaro%E2%80%93Winkler_distance\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse List::Util qw(min max);\n\nsub jaro {\n    my ($s, $t) = @_;\n\n    my $s_len = length($s);\n    my $t_len = length($t);\n\n    return 1 if ($s_len == 0 and $t_len == 0);\n\n    my $match_distance = int(max($s_len, $t_len) / 2) - 1;\n\n    my @s_matches;\n    my @t_matches;\n\n    my @s = split(//, $s);\n    my @t = split(//, $t);\n\n    my $matches = 0;\n    foreach my $i (0 .. $s_len - 1) {\n\n        my $start = max(0, $i - $match_distance);\n        my $end = min($i + $match_distance + 1, $t_len);\n\n        foreach my $j ($start .. $end - 1) {\n            $t_matches[$j] and next;\n            $s[$i] eq $t[$j] or next;\n            $s_matches[$i] = 1;\n            $t_matches[$j] = 1;\n            $matches++;\n            last;\n        }\n    }\n\n    return 0 if $matches == 0;\n\n    my $k     = 0;\n    my $trans = 0;\n\n    foreach my $i (0 .. $s_len - 1) {\n        $s_matches[$i] or next;\n        until ($t_matches[$k]) { ++$k }\n        $s[$i] eq $t[$k] or ++$trans;\n        ++$k;\n    }\n\n#<<<\n    (($matches / $s_len) + ($matches / $t_len)\n        + (($matches - $trans / 2) / $matches)) / 3;\n#>>>\n}\n\nsub jaro_winkler {\n    my ($s, $t) = @_;\n\n    my $distance = jaro($s, $t);\n\n    my $prefix = 0;\n    foreach my $i (0 .. min(3, length($s), length($t))) {\n        substr($s, $i, 1) eq substr($t, $i, 1) ? ++$prefix : last;\n    }\n\n    $distance + $prefix * 0.1 * (1 - $distance);\n}\n\nprintf(\"%f\\n\", jaro_winkler(\"MARTHA\",      \"MARHTA\"));\nprintf(\"%f\\n\", jaro_winkler(\"DWAYNE\",      \"DUANE\"));\nprintf(\"%f\\n\", jaro_winkler(\"DIXON\",       \"DICKSONX\"));\nprintf(\"%f\\n\", jaro_winkler(\"ROSETTACODE\", \"ROSETTASTONE\"));\n"
  },
  {
    "path": "Text/levenshtein_distance_iter.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 12 December 2016\n# https://github.com/trizen\n\n# Levenshtein distance (iterative implementation).\n\n# See also:\n#   https://en.wikipedia.org/wiki/Levenshtein_distance\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse List::Util qw(min);\n\nsub leven {\n    my ($s, $t) = @_;\n\n    my $tl = length($t);\n    my $sl = length($s);\n\n    my @d = ([0 .. $tl], map { [$_] } 1 .. $sl);\n\n    foreach my $i (0 .. $sl - 1) {\n        foreach my $j (0 .. $tl - 1) {\n            $d[$i + 1][$j + 1] =\n              substr($s, $i, 1) eq substr($t, $j, 1)\n              ? $d[$i][$j]\n              : 1 + min($d[$i][$j + 1], $d[$i + 1][$j], $d[$i][$j]);\n        }\n    }\n\n    $d[-1][-1];\n}\n\nsay leven('rosettacode', 'raisethysword');\n"
  },
  {
    "path": "Text/levenshtein_distance_rec.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 12 December 2016\n# https://github.com/trizen\n\n# Levenshtein distance (recursive implementation).\n\n# See also:\n#   https://en.wikipedia.org/wiki/Levenshtein_distance\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse List::Util qw(min);\nuse Memoize qw(memoize);\n\nmemoize('leven');\n\nsub leven {\n    my ($s, $t) = @_;\n\n    return length($t) if $s eq '';\n    return length($s) if $t eq '';\n\n    my ($s1, $t1) = (substr($s, 1), substr($t, 1));\n\n    (substr($s, 0, 1) eq substr($t, 0, 1))\n      ? leven($s1, $t1)\n      : min(\n            leven($s1, $t1),\n            leven($s,  $t1),\n            leven($s1, $t ),\n        ) + 1;\n}\n\nsay leven('rosettacode', 'raisethysword');\n"
  },
  {
    "path": "Text/markov_chain_text_generator.pl",
    "content": "#!/usr/bin/perl\n\n# A very simple text generator, using Markov chains.\n\n# This version uses prefixes of variable lengths, between `n_min` and `n_max`.\n\n# See also:\n#   https://en.wikipedia.org/wiki/Markov_chain\n#   https://rosettacode.org/wiki/Markov_chain_text_generator\n\nuse 5.014;\nuse strict;\nuse warnings;\n\nuse Encode qw(decode_utf8);\nuse Text::Unidecode qw(unidecode);\nuse List::Util qw(uniq);\n\nmy $n_min = 2;\nmy $n_max = 4;\nmy $max   = 200 - $n_max;\n\nsub build_dict {\n    my (@orig_words) = @_;\n\n    my %dict;\n\n    foreach my $n ($n_min .. $n_max) {\n\n        my @words = (@orig_words, @orig_words[0 .. $n - 1]);\n\n        for my $i (0 .. $#words - $n) {\n            my @prefix = @words[$i .. $i + $n - 1];\n            push @{$dict{join ' ', @prefix}}, $words[$i + $n];\n        }\n    }\n\n    foreach my $key(keys %dict) {\n        $dict{$key} = [uniq(@{$dict{$key}})];\n    }\n\n    return %dict;\n}\n\nmy $text = do {\n    if (-t STDIN) {\n        my $content = '';\n        foreach my $file (@ARGV) {\n            open my $fh, '<', $file;\n            local $/;\n            $content .= <$fh>;\n            $content .= \"\\n\";\n        }\n        $content;\n    }\n    else {\n        local $/;\n        <>;\n    }\n};\n\n$text = decode_utf8($text);\n$text = unidecode($text);\n$text = lc($text);\n\n$text =~ s/[^\\w'-]+/ /g;\n\nmy @words = grep { /^[a-z]/ } split ' ', $text;\n\nmy %dict  = build_dict(@words);\nmy $idx   = int(rand(@words - $n_max));\nmy @rotor = @words[$idx .. $idx + $n_min - 1];\nmy @chain = @rotor;\n\nsub pick_next {\n    my (@prefix) = @_;\n\n    my $key = join(' ', @prefix);\n    my @arr = @{$dict{$key}};\n\n    $arr[rand @arr];\n}\n\nfor (1 .. $max) {\n\n    my $new = pick_next(@rotor);\n    my $idx = int(rand($n_max - $n_min + 1) + $n_min - 1);\n\n    if ($idx > $#rotor) {\n        #shift(@rotor) if rand(1) < 0.5;\n    }\n    else {\n        @rotor = @rotor[$#rotor - $idx + 1 .. $#rotor];\n    }\n\n    push @rotor, $new;\n    push @chain, $new;\n}\n\nwhile (@chain) {\n    say join(' ', splice(@chain, 0, 8));\n}\n"
  },
  {
    "path": "Text/orthogonal_text_scrambling.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 29 July 2017\n# https://github.com/trizen\n\n# An interesting text scrambling algorithm, invented by the author in ~2008.\n\nuse utf8;\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub scramble {\n    my ($str) = @_;\n\n    my $i = length($str);\n    $str =~ s/(.{$i})(.)/$2$1/sg while (--$i > 0);\n    return $str;\n}\n\nsub unscramble {\n    my ($str) = @_;\n\n    my $i = 0;\n    my $l = length($str);\n    $str =~ s/(.)(.{$i})/$2$1/sg while (++$i < $l);\n    return $str;\n}\n\nmy $abc = \"abcdefghijklmnopqrstuvwxyz\";\n\nsay scramble($abc);                #=> \"fvjnabdsgrpzxqeholmictyuwk\"\nsay unscramble(scramble($abc));    #=> \"abcdefghijklmnopqrstuvwxyz\"\n"
  },
  {
    "path": "Text/orthogonal_text_scrambling_double.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 29 July 2017\n# https://github.com/trizen\n\n# An interesting text scrambling algorithm, invented by the author in ~2008.\n\nuse utf8;\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub scramble {\n    my ($str) = @_;\n\n    my $i = my $l = length($str);\n\n    $str =~ s/(.{$i})(.)/$2$1/sg while (--$i > 0);\n    $str =~ s/(.{$i})(.)/$2$1/sg while (++$i < $l);\n\n    return $str;\n}\n\nsub unscramble {\n    my ($str) = @_;\n\n    my $i = my $l = length($str);\n\n    $str =~ s/(.)(.{$i})/$2$1/sg while (--$i > 0);\n    $str =~ s/(.)(.{$i})/$2$1/sg while (++$i < $l);\n\n    return $str;\n}\n\nmy $abc = \"abcdefghijklmnopqrstuvwxyz\";\n\nsay scramble($abc);                #=> \"ckytmliqzrbjwuexhogpdsanvf\"\nsay unscramble(scramble($abc));    #=> \"abcdefghijklmnopqrstuvwxyz\"\n"
  },
  {
    "path": "Text/repeated_substrings.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 27 April 2015\n# website: https://github.com/trizen\n\n# Find repeated substrings of a string. (fast solution)\n\n# usage: perl repeated_substrings.pl < file.txt\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nsub rep_substrings {\n    my ($str, $min, $max) = @_;\n\n    my $limit = length($str);\n\n    $min //= 4;\n    $max //= int($limit) / 2;\n\n    my @reps;\n    my $cur_pos = $min;\n    my $old_pos = 0;\n    my $old_n   = 0;\n\n    while ($cur_pos < $limit) {\n\n        my $n   = 2;\n        my $pos = 0;\n        my $matched;\n\n        while (   $pos != $old_pos + 1\n               && $cur_pos + $n <= $limit\n               && $n <= $max\n               && (my $p = index(substr($str, 0, $cur_pos), substr($str, $cur_pos, $n), $pos)) >= 0) {\n            ++$n;\n            $pos = $p;\n            !$matched && $n > $min && ($matched = 1);\n        }\n\n        if ($pos == $old_pos + 1) {\n            $cur_pos += $old_n - 1;\n        }\n        else {\n            push @reps, [$cur_pos, $pos, $n - 1, substr($str, $cur_pos, $n - 1)] if $matched;\n            $cur_pos += 1;\n        }\n\n        $old_pos = $pos;\n        $old_n   = $n - 1;\n    }\n\n    return \\@reps;\n}\n\nmy $text = @ARGV ? do { local $/; <> } : 'TOBEORNOTTOBEORTOBEORNOT#';\nmy $positions = rep_substrings($text);\n\nmy $total_len = 0;\nforeach my $group (@{$positions}) {\n    $total_len += length($group->[-1]);\n}\n\neval {\n    require Data::Dump;\n    say Data::Dump::pp($positions);\n};\n\nsay \"\\n** A total of $total_len characters!\\n\";\n"
  },
  {
    "path": "Text/search_by_prefix.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 29 July 2016\n# Website: https://github.com/trizen\n\n# Analyzes a list of strings and returns those that have a certain prefix\n\npackage Search::ByPrefix;\n\nuse 5.014;\nuse strict;\nuse warnings;\n\nsub new {\n    my ($class, %opt) = @_;\n    bless {table => $opt{table} // {}}, $class;\n}\n\nsub add {\n    my ($self, $key, $value) = @_;\n\n    my $ref = $self->{table};\n    foreach my $item (@$key) {\n        $ref = $ref->{$item} //= {};\n        push @{$ref->{values}}, \\$value;\n    }\n\n    $self;\n}\n\nsub search {\n    my ($self, $pattern) = @_;\n\n    my $ref = $self->{table};\n\n    foreach my $item (@$pattern) {\n        if (exists $ref->{$item}) {\n            $ref = $ref->{$item};\n        }\n        else {\n            return;\n        }\n    }\n\n    map { $$_ } @{$ref->{values}};\n}\n\npackage main;\n\nuse File::Spec::Unix;\nmy $obj = Search::ByPrefix->new;\n\nsub make_key {\n    [File::Spec::Unix->splitdir($_[0])];\n}\n\nforeach my $dir (\n                 qw(\n                 /home/user1/tmp/coverage/test\n                 /home/user1/tmp/covert/operator\n                 /home/user1/tmp/coven/members\n                 /home/user1/tmp2/coven/members\n                 /home/user2/tmp2/coven/members\n                 )\n  ) {\n    $obj->add(make_key($dir), $dir);\n}\n\n# Finds the common directories\nsay for $obj->search(make_key('/home/user1/tmp'));\n"
  },
  {
    "path": "Text/sim_end_words.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 17 April 2012\n# https://github.com/trizen\n\n# Group and list words from a wordlist that have similar ending chars\n\nuse strict;\nuse warnings;\n\nuse open IO => ':utf8', ':std';\nuse Getopt::Long qw(GetOptions);\n\nmy $min = 4;\nmy $max = 15;\n\nmy $min_words = 2;\nmy $max_words = 'inf';\n\nmy $unique = 0;\n\nGetOptions(\n           'end-min|end_min=i'     => \\$min,\n           'end-max|end_max=i'     => \\$max,\n           'group-min|group_min=i' => \\$min_words,\n           'group-max|group_max=i' => \\$max_words,\n           'unique!'               => \\$unique,\n          )\n  or die \"Error in command-line arguments!\";\n\n@ARGV or die <<\"HELP\";\nusage: $0 [options] wordlists\n\noptions:\n       --end-min=i   : minimum number of similar characters (default: $min)\n       --end-max=i   : maximum number of similar characters (default: $max)\n       --group-min=i : minimum number of words per group (default: $min_words)\n       --group-max=i : maximum number of words per group (default: $max_words)\n       --unique!     : don't use the same word in different groups (default: $unique)\nHELP\n\n--$min;    # starting with zero\n\nforeach my $file (grep { -f } @ARGV) {\n    my %table;\n    open my $fh, '<', $file or do { warn \"$0: can't open file $file: $!\"; next };\n    while (defined(my $line = <$fh>)) {\n        chomp $line;\n\n        next if (my $length = length($line)) <= $min;\n        --$length;    # same as $#chars\n\n        my @chars = split //, $line;\n        for (my $i = $length - $min ; $i >= 0 ; --$i) {\n            push @{$table{join q{}, @chars[$i .. $length]}}, $line;\n        }\n    }\n    close $fh;\n\n    my %data;\n    my %seen;\n    {\n        local $, = \"\\n\";\n        local $\\ = \"\\n\";\n        foreach my $key (\n                         map  { $_->[1] }\n                         sort { $b->[0] <=> $a->[0] }\n                         map  { [scalar @{$table{$_}} => $_] } keys %table\n          ) {\n            next if length($key) > $max;\n            @{$table{$key}} = do {\n                my %s;\n                grep { !$s{$_}++ } @{$table{$key}};\n            };\n            my $items = @{$table{$key}};\n            next if $items < $min_words;\n            next if $items > $max_words;\n\n            if ($unique) {\n                @{$table{$key}} = grep { not exists $seen{$_} } @{$table{$key}};\n                @{$table{$key}} or next;\n                @seen{@{$table{$key}}} = ();\n            }\n\n            #print \"\\e[1;46m$key\\e[0m\";\n            print \"\\t\\t\\t==$key==\";\n            print @{$table{$key}};\n        }\n    }\n}\n"
  },
  {
    "path": "Text/smartWordWrap.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 15th October 2013\n# https://trizenx.blogspot.com\n\n# Smart word wrap algorithm\n# See: https://en.wikipedia.org/wiki/Word_wrap#Minimum_raggedness\n\nuse 5.016;\nuse strict;\nuse warnings;\n\npackage Smart::Word::Wrap {\n\n    sub new {\n        my (undef, %args) = @_;\n\n        my %opt = (\n                   width => 6,\n                   text  => '',\n                  );\n\n        foreach my $key (keys %args) {\n            if (exists $opt{$key}) {\n                $opt{$key} = delete $args{$key};\n            }\n            else {\n                local $\" = ', ';\n                die \"ERROR: invalid key-option '$key' (expected one of {@{[keys %opt]}})\";\n            }\n        }\n\n        bless \\%opt, __PACKAGE__;\n    }\n\n    # This is the ugliest function! It, recursively,\n    # prepares the words for the make_paths() function.\n    sub prepare_words {\n        my ($self, @array) = @_;\n\n        my @root;\n        my $len = 0;\n\n        for (my $i = 0 ; $i <= $#array ; $i++) {\n            $len += (my $wordLen = length($array[$i]));\n\n            if ($len > $self->{width}) {\n                if ($wordLen > $self->{width}) {\n                    $len -= $wordLen;\n                    splice(@array, $i, 1, unpack \"(A$self->{width})*\", $array[$i]);\n                    $i--, next;\n                }\n                last;\n            }\n\n            push @root, [@array[0 .. $i], __SUB__->($self, @array[$i + 1 .. $#{array}])];\n            last if ++$len >= $self->{width};\n        }\n\n        @root ? @root : @array ? \\@array : ();\n    }\n\n    # This function creates all the\n    # available paths, for further processing.\n    sub make_paths {\n        my (@array) = @_;\n\n        my @head;\n        while (@array) {\n            last if ref($array[0]) eq 'ARRAY';\n            push @head, shift @array;\n        }\n\n        my @row;\n        foreach my $path (@array) {\n            push @row, {\"@head\" => __SUB__->(@{$path})};\n        }\n\n        @row ? \\@row : \"@head\";\n    }\n\n    # This function combines the\n    # the parents with the children.\n    sub combine {\n        my ($root, $hash) = @_;\n\n        my @row;\n        while (my ($key, $value) = each %{$hash}) {\n            push @{$root}, $key;\n\n            if (ref $value eq 'ARRAY') {\n                foreach my $item (@{$value}) {\n                    push @row, __SUB__->($root, $item);\n                }\n            }\n            else {\n                push @row, @{$root}, $value;\n            }\n\n            pop @{$root};\n        }\n\n        \\@row;\n    }\n\n    # This function normalize the combinations.\n    # Example: [[[\"abc\"]]] is normalized to [\"abc\"];\n    sub normalize {\n        my ($array_ref) = @_;\n\n        my @strings;\n        foreach my $item (@{$array_ref}) {\n\n            if (ref $item eq 'ARRAY') {\n                push @strings, __SUB__->($item);\n            }\n            else {\n                push @strings, $array_ref;\n                last;\n            }\n        }\n\n        @strings;\n    }\n\n    # This function finds the best\n    # combination available and returns it.\n    sub find_best {\n        my ($self, @arrays) = @_;\n\n        my %best = (score => 'inf');\n\n        foreach my $array_ref (@arrays) {\n\n            my $score = 0;\n            foreach my $string (@{$array_ref}) {\n                $score += ($self->{width} - length($string))**2;\n            }\n\n            if ($score < $best{score}) {\n                $best{score} = $score;\n                $best{value} = $array_ref;\n            }\n        }\n\n        exists($best{value}) ? @{$best{value}} : ();\n    }\n\n    # This is the main function of the algorithm\n    # which calls all the other functions and\n    # returns the best possible wrapped string.\n    sub smart_wrap {\n        my ($self, %opt) = @_;\n\n        if (%opt) {\n            $self = $self->new(%{$self}, %opt);\n        }\n\n        my @words =\n          ref($self->{text}) eq 'ARRAY'\n          ? @{$self->{text}}\n          : split(' ', $self->{text});\n\n        my @paths;\n        foreach my $group ($self->prepare_words(@words)) {\n            push @paths, make_paths(@{$group});\n        }\n\n        my @combinations;\n        while (@paths) {\n\n            if (ref($paths[0]) eq 'ARRAY') {\n                push @paths, @{shift @paths};\n                next;\n            }\n\n            my $path = shift @paths;\n            push @combinations, ref($path) eq 'HASH' ? [combine([], $path)] : [$path];\n        }\n\n        join(\"\\n\", $self->find_best(normalize(\\@combinations)));\n    }\n\n}\n\n#\n## Usage example\n#\n\nmy $text = 'aaa bb cc ddddd';\n\nmy $obj = Smart::Word::Wrap->new(width => 7);\n\nsay \"=>>> SMART WRAP:\";\nsay $obj->smart_wrap(text => $text);\n\nsay \"\\n=>>> GREEDY WRAP (Text::Wrap):\";\nrequire Text::Wrap;\n$Text::Wrap::columns = $obj->{width};\n$Text::Wrap::columns += 1;\nsay Text::Wrap::wrap('', '', $text);\n"
  },
  {
    "path": "Text/smartWordWrap_lazy.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 15th October 2013\n# https://trizenx.blogspot.com\n# https://trizenx.blogspot.com/2013/11/smart-word-wrap.html\n\n# Smart word wrap algorithm\n# See: https://en.wikipedia.org/wiki/Word_wrap#Minimum_raggedness\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse experimental qw(signatures);\n\n# This is the ugliest method! It, recursively,\n# prepares the words for the combine() function.\nsub prepare_words ($words, $width, $callback, $depth = 0) {\n\n    my @root;\n    my $len = 0;\n    my $i   = -1;\n\n    my $limit = $#{$words};\n    while (++$i <= $limit) {\n        $len += (my $word_len = length($words->[$i]));\n\n        if ($len > $width) {\n            if ($word_len > $width) {\n                $len -= $word_len;\n                splice(@$words, $i, 1, unpack(\"(A$width)*\", $words->[$i]));\n                $limit = $#{$words};\n                --$i;\n                next;\n            }\n            last;\n        }\n\n#<<<\n        push @root, [\n            join(' ', @{$words}[0 .. $i]),\n            prepare_words([@{$words}[$i + 1 .. $limit]], $width, $callback, $depth + 1),\n        ];\n#>>>\n\n        if ($depth == 0) {\n            $callback->($root[0]);\n            @root = ();\n        }\n\n        last if (++$len > $width);\n    }\n\n    \\@root;\n}\n\n# This function combines the\n# the parents with the children.\nsub combine ($path, $callback, $root = []) {\n    my $key = shift(@$path);\n    foreach my $value (@$path) {\n        push @$root, $key;\n        if (@$value) {\n            foreach my $item (@$value) {\n                combine($item, $callback, $root);\n            }\n        }\n        else {\n            $callback->($root);\n        }\n        pop @$root;\n    }\n}\n\n# This is the main function of the algorithm\n# which calls all the other functions and\n# returns the best possible wrapped string.\nsub smart_wrap ($text, $width) {\n\n    my @words = (\n                 ref($text) eq 'ARRAY'\n                 ? @{$text}\n                 : split(' ', $text)\n                );\n\n    my %best = (\n                score => 'inf',\n                value => [],\n               );\n\n    prepare_words(\n        \\@words,\n        $width,\n        sub ($path) {\n            combine(\n                $path,\n                sub ($combination) {\n                    my $score = 0;\n                    foreach my $line (@{$combination}[0 .. $#{$combination} - 1]) {\n                        $score += ($width - length($line))**2;\n                    }\n                    if ($score < $best{score}) {\n                        $best{score} = $score;\n                        $best{value} = [@$combination];\n                    }\n                }\n            );\n        }\n    );\n\n    join(\"\\n\", @{$best{value}});\n}\n\n#\n## Usage examples\n#\n\nmy $text = 'aaa bb cc ddddd';\nsay smart_wrap($text, 6);\n\nsay '-' x 80;\n\n$text = 'Lorem ipsum dolor sit amet, consectetur adipiscing elit.';\nsay smart_wrap($text, 20);\n\nsay '-' x 80;\n\n$text = \"Lorem ipsum dolor ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZ amet, consectetur adipiscing elit.\";\nsay smart_wrap($text, 20);\n\nsay '-' x 80;\n\n$text = 'As shown in the above phases (or steps), the algorithm does many useless transformations';\nsay smart_wrap($text, 20);\n\nsay '-' x 80;\n\n$text = 'Will Perl6 also be pre-installed on future Mac/Linux operating systems? ... I can\\'t predict the success of the project';\nsay smart_wrap($text, 20);\n\nsay '-' x 80;\n\nsay smart_wrap(['a' .. 'n'], 5);\n"
  },
  {
    "path": "Text/smartWordWrap_simple.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 15th October 2013\n# https://trizenx.blogspot.com\n\n# Smart word wrap algorithm\n# See: https://en.wikipedia.org/wiki/Word_wrap#Minimum_raggedness\n\nuse 5.016;\nuse strict;\nuse warnings;\n\npackage Smart::Word::Wrap {\n\n    sub new {\n        my (undef, %args) = @_;\n\n        my %opt = (\n                   width => 6,\n                   text  => '',\n                  );\n\n        foreach my $key (keys %args) {\n            if (exists $opt{$key}) {\n                $opt{$key} = delete $args{$key};\n            }\n            else {\n                local $\" = ', ';\n                die \"ERROR: invalid key-option '$key' (expected one of {@{[keys %opt]}})\";\n            }\n        }\n\n        bless \\%opt, __PACKAGE__;\n    }\n\n    # This is the ugliest function! It, recursively,\n    # prepares the words for the combine() function.\n    sub prepare_words {\n        my ($self, @array) = @_;\n\n        my @root;\n        my $len = 0;\n\n        for (my $i = 0 ; $i <= $#array ; $i++) {\n            $len += (my $wordLen = length($array[$i]));\n\n            if ($len > $self->{width}) {\n                if ($wordLen > $self->{width}) {\n                    $len -= $wordLen;\n                    splice(@array, $i, 1, unpack \"(A$self->{width})*\", $array[$i]);\n                    $i--, next;\n                }\n                last;\n            }\n\n            push @root, {\"@array[0 .. $i]\" => __SUB__->($self, @array[$i + 1 .. $#{array}])};\n            last if ++$len >= $self->{width};\n        }\n\n        @root ? \\@root : undef;\n    }\n\n    # This function combines the\n    # the parents with the children.\n    sub combine {\n        my ($root, $hash) = @_;\n\n        my @row;\n        while (my ($key, $value) = each %{$hash}) {\n            push @{$root}, $key;\n\n            if (ref $value eq 'ARRAY') {\n                foreach my $item (@{$value}) {\n                    push @row, __SUB__->($root, $item);\n                }\n            }\n            else {\n                @row = [@{$root}];\n            }\n\n            pop @{$root};\n        }\n\n        @row;\n    }\n\n    # This function finds the best\n    # combination available and returns it.\n    sub find_best {\n        my ($self, @arrays) = @_;\n\n        my %best = (\n                    score => 'inf',\n                    value => [],\n                   );\n\n        foreach my $array_ref (@arrays) {\n\n            my $score = 0;\n            foreach my $string (@{$array_ref}) {\n                $score += ($self->{width} - length($string))**2;\n            }\n\n            if ($score < $best{score}) {\n                $best{score} = $score;\n                $best{value} = $array_ref;\n            }\n        }\n\n        @{$best{value}};\n    }\n\n    # This is the main function of the algorithm\n    # which calls all the other functions and\n    # returns the best possible wrapped string.\n    sub smart_wrap {\n        my ($self, %opt) = @_;\n\n        if (%opt) {\n            $self = $self->new(%{$self}, %opt);\n        }\n\n        my @words =\n          ref($self->{text}) eq 'ARRAY'\n          ? @{$self->{text}}\n          : split(' ', $self->{text});\n\n        join \"\\n\", $self->find_best(map { combine([], $_) } @{$self->prepare_words(@words)});\n    }\n\n}\n\n#\n## Usage example\n#\n\nmy $text = 'As shown in the above phases (or steps), the algorithm does many useless transformations';\n\nmy $obj = Smart::Word::Wrap->new(width => 20);\n\nsay \"=>>> SMART WRAP:\";\nsay $obj->smart_wrap(text => $text);\n\nsay \"\\n=>>> GREEDY WRAP (Text::Wrap):\";\nrequire Text::Wrap;\n$Text::Wrap::columns = $obj->{width};\n$Text::Wrap::columns += 1;\nsay Text::Wrap::wrap('', '', $text);\n\nsay \"\\n\", '-' x 80, \"\\n\";\n\nsay \"=>>> SMART WRAP:\";\n$text = 'Lorem ipsum dolor sit amet, consectetur adipiscing elit.';\nsay $obj->smart_wrap(text => $text);\n\nsay \"\\n=>>> GREEDY WRAP (Text::Wrap):\";\nsay Text::Wrap::wrap('', '', $text);\n"
  },
  {
    "path": "Text/unique_prefixes.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 28 September 2014\n# Website: https://github.com/trizen\n\n# Find the unique prefixes for an array of arrays of strings\n\nuse 5.016;\nuse strict;\nuse warnings;\n\nsub abbrev {\n    my ($array, $code) = @_;\n\n    my $__END__  = {};                     # some unique value\n    my $__CALL__ = ref($code) eq 'CODE';\n\n    my %table;\n    foreach my $sub_array (@{$array}) {\n        my $ref = \\%table;\n        foreach my $item (@{$sub_array}) {\n            $ref = $ref->{$item} //= {};\n        }\n        $ref->{$__END__} = $sub_array;\n    }\n\n    my @abbrevs;\n    sub {\n        my ($hash) = @_;\n\n        foreach my $key (my @keys = sort keys %{$hash}) {\n            next if $key eq $__END__;\n            __SUB__->($hash->{$key});\n\n            if ($#keys > 0) {\n                my $count = 0;\n                my $ref   = $hash->{$key};\n                while (my ($key) = each %{$ref}) {\n                    if ($key eq $__END__) {\n                        my $arr = [@{$ref->{$key}}[0 .. $#{$ref->{$key}} - $count]];\n                        $__CALL__ ? $code->($arr) : push(@abbrevs, $arr);\n                        last;\n                    }\n                    $ref = $ref->{$key};\n                    $count++;\n                }\n            }\n        }\n      }\n      ->(\\%table);\n\n    return \\@abbrevs;\n}\n\n#\n## Example: find the common directory from a list of dirs\n#\n\nmy @dirs = qw(\n  /home/user1/tmp/coverage/test\n  /home/user1/tmp/covert/operator\n  /home/user1/tmp/coven/members\n  );\n\nrequire List::Util;\nmy $unique_prefixes = abbrev([map { [split('/')] } @dirs]);\nmy %table = map { $#{$_} => $_ } @{$unique_prefixes};\nmy $min = List::Util::min(keys %table);\n\nsay \"=>> Common directory:\";\nsay join('/', splice(@{$table{$min}}, 0, -1));\n\nmy @words = qw(\n  deodorant\n  decor\n  decorat\n  decadere\n  plecare\n  placere\n  plecat\n  jaguar\n  );\n\nsay \"\\n=>> Unique prefixes:\";\nabbrev([map { [split //] } @words], sub { say @{$_[0]} });\n"
  },
  {
    "path": "Text/word_roots.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 11th September 2014\n# https://github.com/trizen\n\n# Find the minimum word derivations for a list of words\n\nuse 5.016;\nuse strict;\nuse warnings;\n\nno warnings 'recursion';\n\nsub make_tree {\n    my ($fh) = @_;\n\n    my %table;\n    while (defined(my $word = unpack('A*', scalar(<$fh>) // last))) {\n        my $ref = \\%table;\n        foreach my $char (split //, $word) {\n            $ref = $ref->{$char} //= {};\n        }\n        undef $ref->{$word};\n    }\n\n    return \\%table;\n}\n\nsub traverse(&$) {\n    my ($code, $hash) = @_;\n\n    foreach my $key (my @keys = sort keys %{$hash}) {\n        __SUB__->($code, $hash->{$key});\n\n        if ($#keys > 0) {\n\n            my $count = 0;\n            my $ref = my $val = delete $hash->{$key};\n\n            while (my ($key) = each %{$ref}) {\n                $ref = $val = $ref->{$key // last} // ($code->(substr($key, 0, length($key) - $count)), last);\n                ++$count;\n            }\n        }\n    }\n}\n\ntraverse { say shift } make_tree(@ARGV ? \\*ARGV : \\*DATA);\n\n__END__\ndeodorant\ndecor\ndecadere\nplecare\nplacere\nplecat\njaguar\n"
  },
  {
    "path": "Text/word_unscrambler.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# Date: 05 September 2020\n# https://github.com/trizen\n\n# Find words in a given scrambled word, using a dictionary.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse open IO => ':utf8', ':std';\n\nuse Term::ReadLine;\nuse List::Util qw(min uniq);\nuse Algorithm::Combinatorics qw(combinations);\nuse experimental qw(signatures);\nuse Encode qw(decode_utf8);\n\nmy $dict_file = '/usr/share/dict/words';\n\nmy $unidecode        = 0;    # plain ASCII transliterations of Unicode text\nmy $group_by_length  = 1;    # group words by length\nmy $case_insensitive = 0;    # case-insensitive mode\n\nmy $min_length = 3;          # minimum number of letters a word must have\nmy $max_length = 0;          # maximum number of letters a word must have (0 for no limit)\n\nsub normalize_word ($word) {\n\n    if ($unidecode) {        # Unicode to ASCII\n        require Text::Unidecode;\n        $word = Text::Unidecode::unidecode($word);\n    }\n\n    if ($case_insensitive) {\n        $word = CORE::fc($word);\n    }\n\n    return $word;\n}\n\nsub create_optimized_dictionary ($file) {\n\n    open my $fh, '<:utf8', $file\n      or die \"Can't open file <<$file>> for reading: $!\";\n\n    my %dict;\n\n    while (defined(my $line = <$fh>)) {\n\n        $line =~ s{/\\w+}{};\n\n        my @words = split(' ', $line);\n\n        foreach my $word (@words) {\n\n            # Ignore too short words\n            if ($min_length > 0 and length($word) < $min_length) {\n                next;\n            }\n\n            # Ignore too long words\n            if ($max_length > 0 and length($word) > $max_length) {\n                next;\n            }\n\n            $word = normalize_word($word);\n\n            # Add the word into the hash table\n            push(@{$dict{join('', sort split(//, $word))}}, $word);\n        }\n    }\n\n    close $fh;\n    return \\%dict;    # return dictionary\n}\n\nsub find_unscrambled_words ($word, $dict) {\n\n    $word = normalize_word($word);\n\n    my @found;\n    my @chars = sort split(//, $word);    # split word into characters\n\n    foreach my $k (($min_length || 1) .. min($max_length || scalar(@chars), scalar(@chars))) {\n\n        # Create combination of words of k characters\n        my $iter = combinations(\\@chars, $k);\n\n        while (my $arr = $iter->next) {\n\n            my $unscrambled = join('', @$arr);\n\n            # Check each combination if it exists inside the dictionary\n            if (exists $dict->{$unscrambled}) {\n\n                # Store the words made from this combination of letters\n                push @found, @{$dict->{$unscrambled}};\n            }\n        }\n    }\n\n    return uniq(@found);\n}\n\nmy $dict = create_optimized_dictionary($dict_file);\nmy $term = Term::ReadLine->new(\"Word Unscrambler\");\n\nwhile (1) {\n\n    chomp(my $word = decode_utf8($term->readline(\"Word: \") // last));\n\n    my @unscrambled = find_unscrambled_words($word, $dict);\n\n    my %groups;\n    foreach my $word (@unscrambled) {\n        push @{$groups{length($word)}}, $word;\n    }\n\n    say '';\n    foreach my $len (sort { $b <=> $a } keys %groups) {\n\n        if ($group_by_length) {\n            say join(\" \", sort @{$groups{$len}});\n        }\n        else {\n            say for sort @{$groups{$len}};\n        }\n    }\n    say '';\n}\n"
  },
  {
    "path": "Time/calendar.pl",
    "content": "#!/usr/bin/perl\n\n# cal.pl - Display the calendar of a given month.\n# Fedon Kadifeli, 1998 - April 2003.\n# Improved by Trizen - February 2012\n\nmy (%months) = (\n                '1'  => {LENGTH => 31, NAME => 'January'},\n                '2'  => {LENGTH => 28, NAME => 'February'},\n                '3'  => {LENGTH => 31, NAME => 'March'},\n                '4'  => {LENGTH => 30, NAME => 'April'},\n                '5'  => {LENGTH => 31, NAME => 'May'},\n                '6'  => {LENGTH => 30, NAME => 'June'},\n                '7'  => {LENGTH => 31, NAME => 'July'},\n                '8'  => {LENGTH => 31, NAME => 'August'},\n                '9'  => {LENGTH => 30, NAME => 'September'},\n                '10' => {LENGTH => 31, NAME => 'October'},\n                '11' => {LENGTH => 30, NAME => 'November'},\n                '12' => {LENGTH => 31, NAME => 'December'},\n               );\n\nmy ($day, $real_month, $real_year) = (localtime time)[3 .. 5];\nmy ($month, $year) = ($real_month += 1, $real_year += 1900);\n\nif (@ARGV and $ARGV[0] =~ /^(?:\\d\\d?|\\w{3,})$/) {\n    $month = shift @ARGV;\n    if ($month =~ /^ *\\d\\d? *$/) {\n        unless ($month >= 1 and $month <= 12) {\n            die \"Month must be between 1 and 12!\\n\";\n        }\n        $month = int $month;\n    }\n    else {\n        while (my ($k, $v) = each %months) {\n            if ($$v{'NAME'} =~ /^\\Q$month\\E/io) {\n                $month = $k;\n                last;\n            }\n        }\n        $month = $real_month unless $month =~ /^\\d\\d?$/;\n    }\n}\n\nif (@ARGV and $ARGV[0] =~ /^\\d\\d\\d\\d$/) {\n    $year = int shift @ARGV;\n}\n\nprintf \"%*s\\n%s\\n\", 11 + (5 + length($months{$month}{'NAME'})) / 2,\n  \"$months{$month}{'NAME'} $year\", 'Su Mo Tu We Th Fr Sa';\n\nif ($year % 400 == 0 or $year % 4 == 0 and $year % 100 != 0) {\n    $months{'2'}{'LENGTH'} = 29;\n}\n--$year;\n\nmy $st = 1 + $year * 365 + int($year / 4) - int($year / 100) + int($year / 400);\n\nforeach my $i (1 .. $month - 1) {\n    $st += $months{$i}{'LENGTH'};\n}\n\nprint q{   } x ($st % 7);\n++$year;\n\nforeach my $i (1 .. $months{$month}{'LENGTH'}) {\n    if ($i == $day and $year == $real_year and $month == $real_month) {\n        printf '%s%2d%s ', \"\\e[7m\", $i, \"\\e[0m\";\n    }\n    else {\n        printf '%2d ', $i;\n    }\n\n    print \"\\n\" if ($st + $i) % 7 == 0 and $i != $months{$month}{'LENGTH'};\n}\n\nprint \"\\n\\n\";\n"
  },
  {
    "path": "Time/contdown.pl",
    "content": "#!/usr/bin/perl\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Time::Piece;\nuse Time::Seconds;\n\nsub _div {\n    my $quot = $_[0] / $_[1];\n    my $int  = int($quot);\n    $int > $quot ? $int - 1 : $int;\n}\n\nsub leap_year {\n    my ($y) = @_;\n    (($y % 4 == 0) and ($y % 400 == 0 or $y % 100 != 0)) || 0;\n}\n\n{\n    #<<<\n    my @days_in_month = (\n                         [0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31],\n                         [0, 31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31],\n                        );\n    #>>>\n\n    sub days_in_month ($$) {\n        my ($y, $m) = @_;\n        $days_in_month[leap_year($y)][$m];\n    }\n}\n\nsub ymd_to_days {\n    my ($Y, $M, $D) = @_;\n\n    if (   $M < 1\n        || $M > 12\n        || $D < 1\n        || ($D > 28 && $D > days_in_month($Y, $M))) {\n        return undef;\n    }\n\n    my $x = ($M <= 2 ? $Y - 1 : $Y);\n    my $days = $D + (undef, -1, 30, 58, 89, 119, 150, 180, 211, 242, 272, 303, 333)[$M];\n\n    $days += 365 * ($Y - 1970);\n    $days += _div(($x - 1968), 4);\n    $days -= _div(($x - 1900), 100);\n    $days += _div(($x - 1600), 400);\n\n    $days;\n}\n\n{\n    my $t = localtime;\n\n    my $now = ymd_to_days($t->year, $t->mon, $t->mday) + $t->sec / (60 * 60 * 24) + $t->min / (60 * 24);\n    my $then = ymd_to_days(2014, 7, 29) - (3 / 24);\n\n    local $| = 1;\n    while ((my $diff = $then - $now) > 0) {\n        printf(\"* Seconds: %d | Minutes: %.2f | Days: %.2f\\r\", 86400 * $diff, 86400 * $diff / 60, $diff);\n        $now += 1 / 86400;\n        sleep 1;\n    }\n}\n"
  },
  {
    "path": "Video/sponsor-free.pl",
    "content": "#!/usr/bin/env perl\n\n# SponsorBlock CLI for YouTube Videos\n# Marks or removes sponsored segments using FFmpeg.\n\n# Dependencies:\n#   ffmpeg\n#   URI\n#   IO::Socket::SSL\n\n# Inspired by:\n#   https://github.com/faissaloo/SponSkrub\n\nuse 5.036;\n\nuse URI;\nuse HTTP::Tiny;\nuse Getopt::Long qw(:config no_ignore_case bundling);\nuse JSON::PP     qw(decode_json encode_json);\nuse Digest::SHA  qw(sha256_hex);\nuse File::Temp   qw(tempfile);\n\n# ==============================================================================\n# Configuration & CLI Parsing\n# ==============================================================================\n\nmy $appname = 'sponsor-free';\nmy $version = '0.01';\n\nmy %cfg = (\n           action     => 'cut',                        # 'cut' or 'chapter'\n           categories => 'sponsor',                    # comma-separated\n           api_url    => 'https://sponsor.ajay.app',\n           direct     => 0,                            # Use direct videoID lookup instead of hash\n           proxy      => $ENV{HTTP_PROXY} // '',\n           keep_date  => 0,\n           tolerance  => 1,                            # tolerance in seconds for video duration (local vs server)\n          );\n\nmy $remove_all = 0;\n\nmy @available_categories = qw(\n  sponsor intro outro interaction selfpromo music_offtopic\n);\n\nGetOptions(\n           'h|help'         => sub { show_help(0) },\n           'v|version'      => sub { show_version() },\n           'a|action=s'     => \\$cfg{action},\n           'c|categories=s' => \\$cfg{categories},\n           'all'            => \\$remove_all,\n           'api-url=s'      => \\$cfg{api_url},\n           'direct'         => \\$cfg{direct},\n           'proxy=s'        => \\$cfg{proxy},\n           'tolerance=f'    => \\$cfg{tolerance},\n           'keep-date'      => \\$cfg{keep_date},\n          )\n  or show_help(1);\n\nif ($remove_all) {\n    $cfg{categories} = join(',', @available_categories);\n}\n\nmy ($video_id, $input_file, $output_file) = @ARGV;\n\nshow_help(1)\n  unless ($video_id && $input_file && $output_file);\n\ndie \"Invalid action: $cfg{action}\\n\" unless $cfg{action} =~ /^(cut|chapter)$/;\n\n# ==============================================================================\n# Main Execution\n# ==============================================================================\n\nmy $duration = extract_duration($input_file);\nmy $bitrate  = extract_bitrate($input_file);\n\ndie \"Could not determine video duration. Is FFmpeg installed?\\n\" unless $duration;\n\nsay \"Fetching SponsorBlock data...\";\nmy @categories = split(',', $cfg{categories});\nmy @sponsors   = fetch_sponsor_data($video_id, \\@categories, $duration);\n\nunless (@sponsors) {\n    say \"No matching segments found. Nothing to do.\";\n    exit 0;\n}\n\nsay \"Found \" . scalar(@sponsors) . \" segment(s).\";\n\nmy @chapters = get_existing_chapters($input_file, $duration);\nmy @merged   = merge_segments(\\@sponsors, \\@chapters);\n\nif ($cfg{action} eq 'chapter') {\n    say \"Injecting chapters...\";\n    my $meta = build_ffmpeg_metadata(@merged);\n    run_ffmpeg_metadata_pass($input_file, $output_file, $meta);\n}\nelse {    # cut\n    say \"Removing segments...\";\n    my @keep = grep { $_->{type} eq 'content' } @merged;\n    my $meta = build_ffmpeg_metadata(recalculate_kept_chapters(@keep));\n\n    my $streams = extract_streams($input_file);\n    my $has_vid = $streams =~ /video/;\n    my $has_aud = $streams =~ /audio/;\n\n    run_ffmpeg_cut_pass($input_file, $output_file, \\@keep, $has_vid, $has_aud, $meta);\n}\n\nif ($cfg{keep_date}) {\n    my @s = stat($input_file);\n    utime($s[8], $s[9], $output_file);\n}\n\nsay \"Success! Output saved to: $output_file\";\nexit 0;\n\n# ==============================================================================\n# API Client\n# ==============================================================================\n\nsub fetch_sponsor_data ($vid, $cats, $duration) {\n    my $http      = HTTP::Tiny->new(proxy => $cfg{proxy} || undef, timeout => 30);\n    my $cats_json = encode_json($cats);\n\n    my $url = URI->new(\"$cfg{api_url}/api/skipSegments\");\n\n    if ($cfg{direct}) {\n        $url->query_form(videoID    => $vid,\n                         categories => $cats_json);\n    }\n    else {\n        my $hash = substr(sha256_hex($vid), 0, 4);    # 4-char prefix is standard for privacy API\n        $url->path($url->path . '/' . $hash);\n        $url->query_form(categories => $cats_json);\n    }\n\n    my $res = $http->get($url);\n    return () if $res->{status} == 404;               # No segments\n    die \"API Error $res->{status}: $res->{reason}\\n\" unless $res->{success};\n\n    my $data = decode_json($res->{content});\n\n    # If using privacy API, filter the returned list by the exact videoID\n    $data = [map { $_->{segments}->@* } grep { $_->{videoID} eq $vid } @$data] unless $cfg{direct};\n\n    foreach my $segment (@$data) {\n        if (abs($segment->{videoDuration} - $duration) > $cfg{tolerance}) {\n            warn \"The input does not match the video duration!\\n\";\n            return ();\n        }\n    }\n\n    return map {\n        ;\n        {\n         start => sprintf('%.6f', $_->{segment}[0]),\n         end   => sprintf('%.6f', $_->{segment}[1]),\n         title => $_->{category},\n         type  => 'sponsor',\n        }\n    } $data->@*;\n}\n\n# ==============================================================================\n# Timeline Mathematics\n# ==============================================================================\n\nsub get_existing_chapters ($file, $duration) {\n\n    my $json_str = ffprobe($file, qw(-show_chapters -print_format json));\n    my $data     = decode_json($json_str // '{}');\n\n    my @chaps =\n      map {\n        ;\n        {\n         start => $_->{start_time},\n         end   => $_->{end_time},\n         title => $_->{tags}{title} // 'Chapter',\n         type  => 'content',\n        }\n      } ($data->{chapters} // [])->@*;\n\n    if (!@chaps) {\n        @chaps = (\n                  {\n                   start => 0,\n                   end   => $duration,\n                   title => 'Content',\n                   type  => 'content',\n                  }\n                 );\n    }\n\n    return @chaps;\n}\n\n# Flattens overlapping intervals (sponsors override content)\nsub merge_segments ($sponsors, $chapters) {\n    my @timeline;\n\n    # Convert all events into start/end points\n    for my $c ($chapters->@*) {\n        push @timeline, {t => $c->{start}, type => 'content_start', title => $c->{title}};\n        push @timeline, {t => $c->{end}, type => 'content_end'};\n    }\n    for my $s ($sponsors->@*) {\n        push @timeline, {t => $s->{start}, type => 'sponsor_start', title => $s->{title}};\n        push @timeline, {t => $s->{end}, type => 'sponsor_end'};\n    }\n\n    @timeline = sort { $a->{t} <=> $b->{t} || $a->{type} cmp $b->{type} } @timeline;\n\n    my @merged;\n    my ($cur_time, $cur_title, $sponsor_depth) = (0, 'Content', 0);\n\n    for my $ev (@timeline) {\n        if ($ev->{t} > $cur_time) {\n            push @merged,\n              {\n                start => $cur_time,\n                end   => $ev->{t},\n                title => $sponsor_depth > 0 ? \"[Skip] $cur_title\" : $cur_title,\n                type  => $sponsor_depth > 0 ? 'sponsor'           : 'content'\n              };\n        }\n        $cur_time = $ev->{t};\n        $sponsor_depth++          if $ev->{type} eq 'sponsor_start';\n        $sponsor_depth--          if $ev->{type} eq 'sponsor_end';\n        $cur_title = $ev->{title} if $ev->{type} =~ /start$/;\n    }\n\n    # Filter out zero-length segments\n    return grep { $_->{end} > $_->{start} } @merged;\n}\n\nsub recalculate_kept_chapters (@kept) {\n    my ($cur, @out) = (0);\n    for my $seg (@kept) {\n        my $len = $seg->{end} - $seg->{start};\n        push @out, {start => $cur, end => $cur + $len, title => $seg->{title}};\n        $cur += $len;\n    }\n    return @out;\n}\n\n# ==============================================================================\n# FFmpeg Wrappers\n# ==============================================================================\n\nsub ffprobe ($file, @args) {\n    chomp(my $out = `ffprobe -loglevel quiet @args \\Q$file\\E 2>&1`);\n    return $? == 0 ? $out : undef;\n}\n\nsub extract_bitrate ($file) {\n    ffprobe($file, qw(-show_entries format=bit_rate -of default=noprint_wrappers=1:nokey=1));\n}\n\nsub extract_duration ($file) {\n    ffprobe($file, qw(-show_entries format=duration -of default=noprint_wrappers=1:nokey=1));\n}\n\nsub extract_streams ($file) {\n    ffprobe($file, qw(-show_entries stream=codec_type -print_format default=noprint_wrappers=1:nokey=1));\n}\n\nsub run_ffmpeg_metadata_pass ($in, $out, $meta) {\n    my $meta_file = create_temp_file($meta);\n    my @cmd =\n      ('ffmpeg', '-y', '-loglevel', 'warning', '-stats', '-i', $in, '-i', $meta_file, '-map_metadata', '1', '-map_chapters', '1', '-codec', 'copy', $out);\n    system(@cmd) == 0 or die \"FFmpeg failed.\\n\";\n    unlink $meta_file;\n}\n\nsub run_ffmpeg_cut_pass ($in, $out, $clips, $has_v, $has_a, $meta) {\n    my $n = scalar $clips->@*;\n\n    my @ts  = sort { $a->{start} <=> $b->{start} } @$clips;\n    my @idx = 0 .. $n - 1;\n\n    my $vouts  = join '', map { \"[vcopy$_]\" } @idx;\n    my $aouts  = join '', map { \"[acopy$_]\" } @idx;\n    my $vclips = join '', map { \"[vcopy$_] trim=$ts[$_]{start}:$ts[$_]{end},setpts=PTS-STARTPTS[v$_],\" } @idx;\n    my $aclips = join '', map { \"[acopy$_] atrim=$ts[$_]{start}:$ts[$_]{end},asetpts=PTS-STARTPTS[a$_],\" } @idx;\n\n    my $filter = '';\n    if ($has_a && $has_v) {\n        $filter = \"[0:v]split=$n$vouts,[0:a]asplit=$n$aouts,${vclips}${aclips}\" . join(' ', map { \"[v$_] [a$_]\" } @idx) . \" concat=n=$n:v=1:a=1[v][a]\";\n    }\n    elsif ($has_v) {\n        $filter = \"[0:v]split=$n$vouts,${vclips}\" . join(' ', map { \"[v$_]\" } @idx) . \" concat=n=$n:v=1[v]\";\n    }\n    elsif ($has_a) {\n        $filter = \"[0:a]asplit=$n$aouts,${aclips}\" . join(' ', map { \"[a$_]\" } @idx) . \" concat=n=$n:v=0:a=1[a]\";\n    }\n\n    my $meta_file = create_temp_file($meta);\n\n    my @cmd = ('ffmpeg', '-y', '-loglevel', 'warning', '-stats', '-i', $in, '-i', $meta_file, '-filter_complex', $filter);\n    push @cmd, '-map', '[v]' if $has_v;\n    push @cmd, '-map', '[a]' if $has_a;\n\n    if ($has_v) {\n\n        # push @cmd, '-b:v', $bitrate;   # for better quality, let ffmpeg decide\n    }\n    elsif ($has_a) {\n        push @cmd, '-b:a', $bitrate;\n    }\n\n    push @cmd, '-map_metadata', '1', '-map_chapters', '1', $out;\n\n    system(@cmd) == 0 or die \"FFmpeg failed.\\n\";\n    unlink $meta_file;\n}\n\nsub build_ffmpeg_metadata (@chapters) {\n    my $meta = \";FFMETADATA1\\n\";\n    for my $ch (@chapters) {\n        $meta .= \"[CHAPTER]\\nTIMEBASE=1/1\\nSTART=$ch->{start}\\nEND=$ch->{end}\\ntitle=$ch->{title}\\n\";\n    }\n    return $meta;\n}\n\nsub create_temp_file ($content) {\n    my ($fh, $file) = tempfile(SUFFIX => '.txt');\n    print $fh $content;\n    close $fh;\n    return $file;\n}\n\nsub show_version {\n    print \"$appname $version\\n\";\n    exit 0;\n}\n\nsub show_help ($code) {\n    local $\" = \",\";\n    print <<\"USAGE\";\nUsage: $0 [options] <video_id> <input> <output>\n\nOptions:\n  -a, --action <type>      Action to perform: 'cut' (default) or 'chapter'.\n  -c, --categories <list>  Comma-separated categories to target. (default: $cfg{categories})\n                           Available: @available_categories\n  --all                    Remove all categories\n  --tolerance <value>      Tolerance, in seconds, for the duration of the video (default: $cfg{tolerance})\n  --direct                 Bypass privacy hash and query API directly via Video ID.\n  --proxy <url>            Route requests through a proxy.\n  --api-url <url>          Override SponsorBlock API URL.\n  --keep-date              Preserve original file modification timestamp.\n  -h, --help               Show this help message.\nUSAGE\n    exit $code;\n}\n"
  },
  {
    "path": "Video/video_concat_ffmpeg.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 21 August 2025\n# https://github.com/trizen\n\n# Concatenate multiple MP4 video files, given as arguments, into one single file called \"CONCATENATED.mp4\".\n\n# Requires: ffmpeg\n\nuse 5.036;\nuse File::Temp            qw(tempfile tempdir);\nuse File::Path            qw(make_path);\nuse File::Spec::Functions qw(catfile curdir);\nuse Image::ExifTool       qw(ImageInfo);\n\nmy $output_filename = \"CONCATENATED.mp4\";\nmy $output_dir      = tempdir(CLEANUP => 1, DIR => curdir());\n\nsub new_tempfile {\n    my ($fh, $filename) = tempfile(\"tmpfileXXXXX\", SUFFIX => '.txt', UNLINK => 1);\n    return ($fh, $filename);\n}\n\nsub make_video_filename($i) {\n    catfile($output_dir, sprintf('output_%05d.mp4', $i));\n}\n\nsub make_ffmpeg_filename_entry($file) {\n    sprintf(\"file '%s'\\n\", $file);\n}\n\nsub ffmpeg_concat_files ($filename, $output_filename) {\n    system('ffmpeg', '-loglevel', 'fatal', '-f', 'concat', '-i', $filename, '-c:v', 'copy', '-c:a', 'aac', '-y', $output_filename);\n    $? == 0 or die \"Stopped with exit code = $?\";\n}\n\nmy $mp4_version = undef;\n\nmy $i = 1;\nmy ($fh, $filename) = new_tempfile();\n\nforeach my $file (@ARGV) {\n\n    my $info    = ImageInfo($file);\n    my $version = $info->{'MajorBrand'};\n\n    $mp4_version //= $version;\n\n    if ($version ne $mp4_version) {\n        $mp4_version = undef;\n        ffmpeg_concat_files($filename, make_video_filename($i));\n        ($fh, $filename) = new_tempfile();\n        ++$i;\n    }\n\n    print $fh make_ffmpeg_filename_entry($file);\n}\n\nffmpeg_concat_files($filename, make_video_filename($i));\n\n($fh, $filename) = new_tempfile();\n\nforeach my $k (1 .. $i) {\n    my $file = make_video_filename($k);\n    print $fh make_ffmpeg_filename_entry($file);\n}\n\nclose $fh;\nffmpeg_concat_files($filename, $output_filename);\n"
  },
  {
    "path": "Video/video_split_ffmpeg.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 24 August 2025\n# https://github.com/trizen\n\n# Split a video file into multiple parts of length `n` seconds, or into `n` equal parts.\n\n# Requires: ffmpeg\n\nuse 5.036;\nuse Getopt::Long qw(GetOptions);\n\nmy $parts           = undef;\nmy $duration        = undef;\nmy $output_template = \"PART_%04d.mp4\";\n\nsub usage($exit_code = 0) {\n\n    print <<\"EOT\";\nusage: $0 [options] [video.mp4]\n\noptions:\n\n    --parts=i     : split into `i` equal parts\n    --duration=i  : split into segments of length `i` seconds\n    --template=s  : output filename template (default: $output_template)\n    --help        : display this message and exit\n\nexample:\n\n    # Split video.mp4 into 3 equal parts\n    perl $0 --parts=3 video.mp4\n\n    # Split video.mp4 into equal parts of 10 seconds length\n    perl $0 --duration=10 video.mp4\nEOT\n\n    exit($exit_code);\n}\n\nGetOptions(\n           \"duration=i\" => \\$duration,\n           \"parts=i\"    => \\$parts,\n           \"template=s\" => \\$output_template,\n           \"h|help\"     => sub { usage() },\n          )\n  or die(\"Error in command line arguments\\n\");\n\nif (!defined($parts) and !defined($duration)) {\n    usage(1);\n}\n\nmy $input_video = shift(@ARGV) // usage(2);\n\nif (not -f $input_video) {\n    die \"Not a file <<$input_video>>: $!\";\n}\n\nif (defined($parts)) {\n    $duration = `ffprobe -v error -show_entries format=duration -of csv=p=0 \\Q$input_video\\E`;\n    chomp($duration);\n    $duration /= $parts;\n}\n\nsystem(qw(ffmpeg -loglevel fatal -i), $input_video,                                qw(-acodec copy -f segment -segment_time),\n       $duration,                     qw(-vcodec copy -reset_timestamps 1 -map 0), $output_template);\n\nif ($? == 0) {\n    say \":: Done!\";\n}\nelse {\n    die \"Something went wrong! ffmpeg exit code: $?\";\n}\n"
  },
  {
    "path": "Visualisators/binview.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# License: GPLv3\n# Date: 09 October 2013\n# https://trizenx.blogspot.com\n\n# Prints bits and bytes (or byte values) from a binary file.\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nsub usage {\n    print STDERR \"usage: $0 file [cols]\\n\";\n    exit 1;\n}\n\nmy $file = shift() // usage();\nmy $cols = shift() // 1;\n\nsysopen my $fh, $file, 0;\nwhile (sysread($fh, (my $chars), $cols) > 0) {\n    foreach (split //, $chars) {\n        printf \"%10s%4s\", unpack(\"B*\"), /[[:print:]]/ ? $_ : sprintf(\"%03d\", ord);\n    }\n    print \"\\n\";\n}\nclose $fh;\n"
  },
  {
    "path": "Visualisators/disk-stats.pl",
    "content": "#!/usr/bin/perl\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 30 January 2013\n# https://github.com/trizen\n\n# Show disk and RAM usage.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse List::Util qw(max);\nuse Term::ANSIColor qw(colored color);\nuse Number::Bytes::Human qw(format_bytes);\n\nmy %CONFIG = (DF_COMMAND => 'df -Th');\n\nsub get_ram {\n\n    # RAM\n    my $freeram   = 0;\n    my $totalram  = 0;\n    my $match_ram = qr/:\\s+(\\d+)/;\n\n    {\n        open my $ram_fh, '<', '/proc/meminfo';\n        while (defined(my $ram_line = <$ram_fh>)) {\n            $totalram = $1 / 1024 if $. == 1 and $ram_line =~ /$match_ram/o;\n            $freeram += $1 / 1024 if $. > 1  and $ram_line =~ /$match_ram/o;\n            last if $. == 4;\n        }\n        close $ram_fh;\n    }\n\n    my $usedram      = $totalram - $freeram;\n    my $used_percent = $usedram / $totalram * 100;\n\n    return\n      scalar {\n              name         => \"/dev/mem\",\n              used         => format_bytes($usedram * 1024**2),\n              total        => format_bytes($totalram * 1024**2),\n              used_percent => $used_percent,\n             };\n}\n\nsub get_partitions {\n    my @partitions;\n    open my $df_pipe, '-|', $CONFIG{DF_COMMAND};\n    while (defined($df_pipe) and defined(my $line = <$df_pipe>)) {\n        chomp($line);\n\n        my (undef, $type, $totalsize, $used, undef, $used_percent, $mountpoint) = split(' ', $line, 7);\n        $used_percent =~ s/^\\d+\\K%\\z// or next;\n\n        #$mountpoint =\n        #    $mountpoint eq '/' ? 'Root'\n        #  : $mountpoint =~ m{^.*/}s ? ucfirst substr($mountpoint, $+[0])\n        #  :                           ucfirst $mountpoint;\n\n        push @partitions,\n          scalar {\n                  name         => $mountpoint,\n                  used_percent => $used_percent,\n                  total        => $totalsize,\n                  used         => $used,\n                 };\n    }\n    close $df_pipe;\n\n    my %seen;\n    return grep { !$seen{join $;, %{$_}}++ } @partitions;\n}\n\nmy @data = (get_ram(), get_partitions());\n\nmy %data;\npush @{$data{names}}, map { $_->{name} } @data;\npush @{$data{usage}}, map { \"$_->{used}/$_->{total}\" } @data;\n\nmy $left_cut  = max(map { length } @{$data{names}});\nmy $right_cut = max(map { length } @{$data{usage}});\n\nmy $width = (split(' ', `stty size`))[1];\n\nforeach my $i (0 .. $#data) {\n\n    my $hash_ref = $data[$i];\n    my $barw     = $width - ($left_cut + $right_cut + 2);\n    my $used     = sprintf \"%.0f\", $barw * ($hash_ref->{used_percent} / 100);\n\n    my $bar   = '';\n    my $pos   = 0;\n    my $bleft = 0;\n\n    my @colors = ([50, 'green'], [80, 'yellow'], [100, 'red']);\n    until ($bleft >= $used) {\n        my ($size, $color) = @{shift @colors};\n\n        my $barsize = sprintf \"%.0f\",\n          $hash_ref->{used_percent} > $size ? (($size - $pos) / 100 * $barw) : ($used - $bleft);\n\n        $bar .= colored('>' x $barsize, \"bold $color\");\n        $pos   += $size;\n        $bleft += $barsize;\n    }\n\n    printf \"%s%-${left_cut}s%s[%s%s]%s%${right_cut}s%s\\n\", color('bright_blue'), $data{names}[$i], color('reset'),\n      $bar, \" \" x ($barw - $used), color('green'), $data{usage}[$i], color('reset');\n}\n"
  },
  {
    "path": "Visualisators/dnscrypt_stats.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# Date: 04 May 2022\n# May the 4th Be With You\n# https://github.com/trizen\n\n# Show human-readable stats for the dnscrypt-proxy query log.\n\nuse 5.020;\nuse strict;\nuse warnings;\n\nuse List::Util qw(sum uniq);\nuse experimental qw(signatures);\nuse Getopt::Long qw(GetOptions);\n\nbinmode(STDOUT, ':utf8');\n\nmy $top      = 10;\nmy $log_file = '/var/log/dnscrypt-proxy/query.log';\n\nsub help {\n    print <<\"EOT\";\nusage: $0 [options]\n\noptions:\n\n    --top=i   : display the top results (default: $top)\n    --file=s  : path to the log file\n    --help    : display this message\n\nEOT\n\n    exit;\n}\n\nGetOptions(\n           \"top=i\"  => \\$top,\n           \"file=s\" => \\$log_file,\n           \"h|help\" => \\&help,\n          )\n  or die(\"Error in command line arguments\\n\");\n\nmy %domains;\nmy %resolvers;\nmy %cache_misses;\nmy %cache_hits;\nmy @durations;\n\nmy @recent_domains;\nmy @recent_resolvers;\n\nopen my $fh, '<:utf8', $log_file\n  or die \"Can't open <<$log_file>>: $!\";\n\nwhile (<$fh>) {\n    if (m{^\\[.*?\\]\\s+\\S+\\s+(\\S+)\\s+\\S+\\s+(\\S+)\\s+(\\S+)\\s+(\\S+)}) {\n        my ($host, $status, $time_ms, $resolver) = ($1, $2, $3, $4);\n\n        $status eq 'PASS' or next;\n\n        $domains{$host}++;\n\n        if ($resolver eq '-') {\n            $resolvers{'--cache--'}++;\n            $cache_hits{$host}++;\n        }\n        else {\n            $cache_misses{$host}++;\n            $resolvers{$resolver}++;\n            push @recent_domains,   $host;\n            push @recent_resolvers, $resolver;\n            push @durations, ($time_ms =~ /^(\\d+)/);\n        }\n    }\n}\n\nclose $fh;\n\nsub make_top ($header, $data) {\n\n    my @entries = sort { ($data->{$b} <=> $data->{$a}) || ($a cmp $b) } keys %$data;\n    my $total   = sum(values %$data);\n\n    if (scalar(@entries) > $top) {\n        $#entries = $top - 1;\n    }\n\n    my @rows;\n    push @rows, sprintf($header, scalar(@entries));\n\n    foreach my $entry (@entries) {\n        push @rows, sprintf(\"%40s  %5d  %2.0f%%\", $entry, $data->{$entry}, $data->{$entry} / $total * 100);\n    }\n\n    return \\@rows;\n}\n\nsub make_recent ($msg, $data) {\n\n    my @entries = uniq(reverse @$data);\n\n    if (scalar(@entries) > $top) {\n        $#entries = $top - 1;\n    }\n\n    my @rows;\n    push @rows, sprintf($msg, scalar(@entries));\n\n    foreach my $entry (@entries) {\n        push @rows, sprintf(\"%50s\", $entry);\n    }\n\n    return \\@rows;\n}\n\nmy @top;\n\npush @top, make_top(\"Top %s resolved domains\", \\%domains);\npush @top, make_top(\"Top %s cache misses\",     \\%cache_misses);\npush @top, make_top(\"Top %s cache hits\",       \\%cache_hits);\npush @top, make_top(\"Top %s resolvers\",        \\%resolvers);\n\npush @top, make_recent(\"Latest %s resolved domains\", \\@recent_domains);\npush @top, make_recent(\"Latest %s resolvers\",        \\@recent_resolvers);\n\nwhile (@top) {\n    my ($x, $y) = splice(@top, 0, 2);\n\n    my ($header1, $header2) = (shift(@$x), shift(@$y));\n    printf(\"%50s %60s\\n\\n\", \"== $header1 == \", \" == $header2 == \");\n\n    while (@$x or @$y) {\n        printf(\"%-60s %s\\n\", shift(@$x) // '', shift(@$y) // '');\n    }\n\n    print \"\\n\";\n}\n\nif (@durations) {\n    say \"\\n:: Average resolving time: \",                   sprintf('%.2f', sum(@durations) / scalar(@durations)),   \"ms.\";\n    say \":: Overall resolving time (including caching): \", sprintf('%.2f', sum(@durations) / sum(values %domains)), \"ms.\";\n}\n"
  },
  {
    "path": "Visualisators/greycmd.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 05 October 2015\n# Website: https://github.com/trizen\n\n# Colorize the output of a given command in nuances of grey.\n\n# Example: perl greycmd.pl ls -l\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Encode qw(decode_utf8);\nuse Text::Tabs qw(expand);\nuse List::Util qw(shuffle max);\nuse Term::ANSIColor qw(colored colorstrip);\n\n@ARGV || die \"usage: $0 [cmd]\\n\";\n\nmy $text = expand(colorstrip(decode_utf8(scalar(`@{[map{quotemeta}@ARGV]}`) // exit 2)));\n\nmy @lines = split(/\\R/, $text);\n\n@lines || exit;    # no output -- exit\n\nmy @colors = (map { \"grey$_\" } 0 .. 23);\n\nmy $max = max(map { length($_) } @lines);\nmy @chars = map { split //, sprintf(\"%-*s\", $max, $_) } @lines;\n\nmy $r = 1 + int($max / @colors);\n\nmy $j = 0;\nmy $k = 0;\n\nforeach my $i (0 .. $#chars) {\n\n    if ($i % $max == 0) {\n        $j = 0;\n    }\n\n    if ($k++ % $r == 0) {\n        ++$j;\n    }\n\n    $chars[$i] eq ' ' and next;             # ignore spaces\n    $chars[$i] =~ /[[:print:]]/ or next;    # ignore non-printable characters\n\n    $chars[$i] = colored($chars[$i], $colors[$j % @colors]);\n}\n\nbinmode(STDOUT, ':utf8');\n\nmy $str = '';\nforeach my $i (0 .. $#chars) {\n    $str .= $chars[$i];\n    if (($i + 1) % $max == 0) {\n        $str = unpack('A*', $str) . \"\\n\";\n    }\n}\nprint $str;\n"
  },
  {
    "path": "Visualisators/human-finder-visual.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 20 April 2014\n# Website: https://github.com/trizen\n\n# A smart human-like substring finder\n# Steps:\n#  1. loop from i=2 and count up to int(sqrt(len(text)))\n#  2. loop from pos=(i-2)*len(substr)*2 and add int(len(text)/i) to pos while pos <= len(text)\n#  3. jump to position pos and scan back and forward and stop if the string is found somewhere nearby\n#  4. loop #2 end\n#  5. loop #1 end\n#  6. return -1\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Term::ANSIColor;\n\nmy $TOTAL = 0;    # count performance\nsub DEBUG () { 1 }    # verbose mode\n\nsub random_find {\n    my ($text, $substr) = @_;\n\n    my $tlen = length($text);\n    my $slen = length($substr);\n\n    my $tmax = $tlen - $slen;\n    my $smax = int($slen / 2);    # this value influences the performance\n\n    my $counter = 0;\n    my $locate  = sub {\n        my ($pos, $guess) = @_;\n\n        for my $i (0 .. $smax) {\n\n            ++$counter if DEBUG;    # measure performance\n\n            if (    $pos + $i <= $tmax\n                and substr($guess, $i) eq substr($substr, 0, $slen - $i)\n                and substr($text,  $pos + $i,             $slen) eq $substr) {\n                printf(\"RIGHT (i: %d; counter: %d):\\n>  %*s\\n>  %s\\n\", $i, $counter, $i + $slen, $substr, $guess) if DEBUG;\n                $TOTAL += $counter if DEBUG;\n                return $pos + $i;\n            }\n            elsif (    $pos - $i >= 0\n                   and substr($substr, $i) eq substr($guess, 0, $slen - $i)\n                   and substr($text,   $pos - $i,            $slen) eq $substr) {\n                printf(\"LEFT (i: %d; counter: %d):\\n>  %s\\n>  %*s\\n\", $i, $counter, $substr, $i + $slen, $guess) if DEBUG;\n                $TOTAL += $counter if DEBUG;\n                return $pos - $i;\n            }\n        }\n\n        return;\n    };\n\n    my %seen;\n    foreach my $i (1 .. int(sqrt($tlen))) {\n        #my $delta = int($tlen / $i)-$slen;\n\n        #my $delta = int(($tlen - $slen));\n        my $delta = int($tlen/$i);\n        #say $delta;\n\n        #for (my $pos = ($i - 1) * $slen ; $pos <= $tmax ; $pos += $delta) {\n        for (my $pos = int($tlen/$i)-$slen ; $pos <= int(sqrt($tlen))*$i; $pos += $delta) {\n\n            #next if $seen{$pos}++;\n\n            #$pos -= $slen;\n            #$delta -= $slen;\n\n            say \"POS: $pos\" if DEBUG;\n            if ($pos + $slen <= $tlen) {\n\n                system 'clear';\n                say substr($text, 0, $pos), color('bold red'), substr($text, $pos, $slen), color('reset'), substr($text, $pos+$slen);\n\n                if (defined(my $i = $locate->($pos, substr($text, $pos, $slen)))) {\n                    say \"** FORWARD MATCH!\" if DEBUG;\n                    return $i;\n                }\n\n                sleep 1;\n            }\n            else {\n                die \"ERROR!\";\n            }\n\n\n\n\n=cut\n            if ($pos >= $slen) {\n\n                system 'clear';\n                say substr($text, 0, $pos-$slen), color('bold red'), substr($text, $pos-$slen, $slen), color('reset'), substr($text, $pos);\n\n                if (defined(my $i = $locate->($pos - $slen, substr($text, $pos - $slen, $slen)))) {\n                    say \"** BACKWARD MATCH!\" if DEBUG;\n                    return $i;\n                }\n\n                sleep 2;\n            }\n=cut\n        }\n    }\n\n    return -1;\n}\n\nmy $text = join('', <DATA>);\nmy $split = 30;\n\nrandom_find($text, q{the blue arcs to});\n\nsay \"TOTAL: \", $TOTAL if DEBUG;\n\n__END__\nThe data structure has one node for every prefix of every\nstring in the dictionary. So if (bca) is in the dictionar\nthen there will be nodes for (bca), (bc), (b), and (). If\nis in the dictionary then it is blue node. Otherwise it i\nThere is a black directed \"child\" arc from each node to a\nis found by appending one character. So there is a black\nThere is a blue directed \"suffix\" arc from each node to t\npossible strict suffix of it in the graph. For example, f\nare (aa) and (a) and (). The longest of these that exists\ngraph is (a). So there is a blue arc from (caa) to (a). T\na green \"dictionary suffix\" arc from each node to the nex\nin the dictionary that can be reached by following blue a\nexample, there is a green arc from (bca) to (a) because (\nnode in the dictionary (i.e. a blue node) that is reached\nthe blue arcs to (ca) and then on to (a).\n"
  },
  {
    "path": "Visualisators/lz_visual.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 21 May 2014\n# License: GPLv3\n# Website: https://github.com/trizen\n\n# A visual variant of the LZ compression.\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse open IO => ':utf8', ':std';\nuse Getopt::Long qw(GetOptions);\nuse Term::ANSIColor qw(colored);\n\nmy $min    = 4;\nmy $buffer = 1024;\n\nsub usage {\n    my ($code) = @_;\n    print <<\"USAGE\";\nusage: $0 [options] [files]\n\noptions:\n        --min=i     : minimum length of a dictionary key (default: $min)\n        --buffer=i  : buffer size of the input stream, in bytes (default: $buffer)\n        --help      : print this message and exit\n\nexample: $0 --min=2 --buffer=512 file.txt\nUSAGE\n    exit($code // 0);\n}\n\nGetOptions(\n           'buffer=i' => \\$buffer,\n           'min=i'    => \\$min,\n           'help'     => \\&usage,\n          )\n  or die(\"Error in command line arguments\\n\");\n\n@ARGV || usage(1);\n\nforeach my $file (@ARGV) {\n    open my $fh, '<', $file;\n    while ((my $len = read($fh, (my $block), $buffer)) > 0) {\n\n        my %dict;\n        my $limit = int($len / 2);\n\n        foreach my $i (reverse($min .. $limit)) {\n            foreach my $j (0 .. $len - $i * 2) {\n                if ((my $pos = index($block, substr($block, $j, $i), $j + $i)) != -1) {\n                    if (not exists $dict{$pos} or $i > $dict{$pos}[1]) {\n                        $dict{$pos} = [$j, $i];\n                    }\n                }\n            }\n        }\n\n        for (my $i = 0 ; $i < $len ; $i++) {\n            if (exists($dict{$i})) {\n                my ($key, $vlen) = @{$dict{$i}};\n                print colored(\"[$key,$vlen]\", 'red');    # this line prints the pointer values\n                print colored(substr($block, $key, $vlen), 'blue');    # this line fetches and prints the real data\n                $i += $vlen - 1;\n            }\n            else {\n                print substr($block, $i, 1);\n            }\n        }\n    }\n    close $fh;\n}\n"
  },
  {
    "path": "Visualisators/matrix_path_2-ways_best.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 08 August 2016\n# Website: https://github.com/trizen\n\n# Visualization for the best minimum path-sum in a matrix.\n# Inspired by: https://projecteuler.net/problem=81\n\n# The path moves only right and down.\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse List::Util qw(min);\nuse Time::HiRes qw(sleep);\nuse Term::ANSIColor qw(colored);\n\nmy @matrix = (\n              [131, 673, 234, 103, 18],\n              [201, 96,  342, 965, 150],\n              [630, 803, 746, 422, 111],\n              [537, 699, 497, 121, 956],\n              [805, 732, 524, 37,  331],\n             );\n\nmy $end = $#matrix;\n\nmy @path;\n\nsub draw {\n    print \"\\e[H\\e[J\\e[H\";\n    my @screen = map {\n        [map { sprintf \"%3s\", $_ } @{$_}]\n    } @matrix;\n\n    foreach my $path (@path) {\n        my ($i, $j) = @$path;\n        $screen[$i][$j] = colored($screen[$i][$j], 'red');\n    }\n\n    foreach my $row (@screen) {\n        say join(' ', @{$row});\n    }\n\n    sleep(0.05);\n}\n\nsub path {\n    my ($i, $j) = @_;\n\n    push @path, [$i, $j];\n    draw();\n    pop @path;\n\n    if ($i < $end and $j < $end) {\n        push @path, [$i, $j];\n        my $sum = $matrix[$i][$j] + min(path($i + 1, $j), path($i, $j + 1));\n        pop @path;\n        return $sum;\n    }\n\n    if ($i < $end) {\n        push @path, [$i, $j];\n        my $sum = $matrix[$i][$j] + path($i + 1, $j);\n        pop @path;\n        return $sum;\n    }\n\n    if ($j < $end) {\n        push @path, [$i, $j];\n        my $sum = $matrix[$i][$j] + path($i, $j + 1);\n        pop @path;\n        return $sum;\n    }\n\n    $matrix[$i][$j];\n}\n\nmy $min_pathsum = path(0, 0);\nsay \"\\nMinimum path sum is: $min_pathsum\\n\";\n"
  },
  {
    "path": "Visualisators/matrix_path_3-ways_best.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 13 August 2016\n# Website: https://github.com/trizen\n\n# The minimal path sum in the 5 by 5 matrix below, by starting in any cell\n# in the left column and finishing in any cell in the right column, and only\n# moving up, down, and right; the sum is equal to 994.\n\n# This algorithm finds the best possible path. (visual version)\n# The problem was taken from: https://projecteuler.net/problem=82\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nno warnings 'recursion';\n\nuse List::Util qw(min);\nuse Time::HiRes qw(sleep);\nuse Term::ANSIColor qw(colored);\n\nmy @matrix = (\n    map {\n        [map { int(rand(1000)) } 1 .. 6]\n      } 1 .. 6\n);\n\nsub draw {\n    my ($path) = @_;\n\n    print \"\\e[H\\e[J\\e[H\";\n    my @screen = map {\n        [map { sprintf \"%3s\", $_ } @{$_}]\n    } @matrix;\n\n    foreach my $p (@$path) {\n        my ($i, $j) = @$p;\n        $screen[$i][$j] = colored($screen[$i][$j], 'red');\n    }\n\n    foreach my $row (@screen) {\n        say join(' ', @{$row});\n    }\n}\n\nmy $end = $#matrix;\n\nsub path {\n    my ($i, $j, $prev, $path) = @_;\n\n    push @$path, [$i, $j];\n\n    $j >= $end && do {\n        return [$matrix[$i][$j], [@$path]];\n    };\n\n    my @paths;\n    if ($i > 0 and $prev ne 'down') {\n        push @paths, path($i - 1, $j, 'up', [@$path]);\n    }\n\n    push @paths, path($i, $j + 1, 'ok', [@$path]);\n\n    if ($i < $end and $prev ne 'up') {\n        push @paths, path($i + 1, $j, 'down', [@$path]);\n    }\n\n    my $min = ['inf', []];\n\n    foreach my $sum (@paths) {\n        $min = $sum if $sum->[0] < $min->[0];\n    }\n\n    pop @$path;\n    [$min->[0] + $matrix[$i][$j], $min->[1]];\n}\n\nmy @sums;\nforeach my $i (0 .. $end) {\n    push @sums, path($i, 0, 'ok', []);\n}\n\nmy $min = (map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [$_, $_->[0]] } @sums)[0];\n\ndraw($min->[1]);\nsay \"Minimum path-sum is: $min->[0]\";\n"
  },
  {
    "path": "Visualisators/matrix_path_3-ways_greedy.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 13 August 2016\n# Website: https://github.com/trizen\n\n# The minimal path sum in the 5 by 5 matrix below, by starting in any cell\n# in the left column and finishing in any cell in the right column, and only\n# moving up, down, and right; the sum is equal to 994.\n\n# This is a greedy algorithm (visual version).\n# The problem was taken from: https://projecteuler.net/problem=82\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Time::HiRes qw(sleep);\nuse Term::ANSIColor qw(colored);\n\nmy @matrix = (\n    map {\n        [map { int(rand(1000)) } 1 .. 6]\n      } 1 .. 6\n);\n\nsub draw {\n    my ($path) = @_;\n\n    print \"\\e[H\\e[J\\e[H\";\n    my @screen = map {\n        [map { sprintf \"%3s\", $_ } @{$_}]\n    } @matrix;\n\n    foreach my $p (@$path) {\n        my ($i, $j) = @$p;\n        $screen[$i][$j] = colored($screen[$i][$j], 'red');\n    }\n\n    foreach my $row (@screen) {\n        say join(' ', @{$row});\n    }\n\n    sleep(0.2);\n}\n\nmy $end = $#matrix;\nmy $min = ['inf', []];\n\nforeach my $i (0 .. $#matrix) {\n    my $sum = $matrix[$i][0];\n\n    my $j    = 0;\n    my $last = 'ok';\n    my @path = [$i, 0];\n\n    while (1) {\n        my @ways;\n\n        if ($i > 0 and $last ne 'down') {\n            push @ways, [-1, 0, $matrix[$i - 1][$j], 'up'];\n        }\n\n        if ($j < $end) {\n            push @ways, [0, 1, $matrix[$i][$j + 1], 'ok'];\n        }\n\n        if ($i < $end and $last ne 'up') {\n            push @ways, [1, 0, $matrix[$i + 1][$j], 'down'];\n        }\n\n        my $m = [0, 0, 'inf', 'ok'];\n\n        foreach my $way (@ways) {\n            $m = $way if $way->[2] < $m->[2];\n        }\n\n        $i   += $m->[0];\n        $j   += $m->[1];\n        $sum += $m->[2];\n        $last = $m->[3];\n\n        push @path, [$i, $j];\n        draw(\\@path);\n        last if $j >= $end;\n    }\n\n    $min = [$sum, \\@path] if $sum < $min->[0];\n}\n\ndraw($min->[1]);\nsay \"Minimum path-sum: $min->[0]\";\n"
  },
  {
    "path": "Visualisators/pview",
    "content": "#!/usr/bin/perl\n\neval 'exec /usr/bin/perl  -S $0 ${1+\"$@\"}'\n    if 0; # not running under some shell\n\n# Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 14 January 2013\n# Latest edit on: 16 July 2015\n# https://github.com/trizen\n\n# Perl source code highlighter.\n\nuse 5.018;\nuse strict;\nuse warnings;\n\nuse open IO => ':utf8', ':std';\n\n#use lib qw(../lib);\nuse Perl::Tokenizer qw(perl_tokens);\nuse Term::ANSIColor qw(color);\n\nmy %scheme = (\n              dereference_operator => color('bright_blue'),\n              fat_comma            => color('bright_blue'),\n              comma                => color('bright_blue'),\n              assignment_operator  => color('bright_blue'),\n              operator             => color('bright_blue'),\n              comment              => color('bright_black'),\n              number               => color('bright_red'),\n              binary_number        => color('bright_red'),\n              hex_number           => color('bright_red'),\n              special_keyword      => color('bold blue'),\n              keyword              => color('bold blue'),\n              file_test            => color('bold blue'),\n              substitution         => color('yellow'),\n              transliteration      => color('bright_yellow'),\n              match_regex          => color('bold yellow'),\n              glob_readline        => color('bold white on_black'),\n              curly_bracket_open   => color('bold'),\n              curly_bracket_close  => color('bold'),\n              right_bracket_open   => color('bold green'),\n              right_bracket_close  => color('bold green'),\n              array_sigil          => color('bright_cyan'),\n              scalar_sigil         => color('bright_green'),\n              hash_sigil           => color('bright_yellow'),\n              glob_sigil           => color('bold cyan'),\n              ampersand_sigil      => color('bold red'),\n              heredoc_beg          => color('bold magenta on_black'),\n              heredoc              => color('bold magenta on_black'),\n              semicolon            => color('red'),\n              qq_string            => color('bright_yellow on_black'),\n              q_string             => color('bright_yellow on_black'),\n              compiled_regex       => color('bold blue on_black'),\n              qx_string            => color('bright_magenta on_black'),\n              backtick             => color('bright_magenta on_black'),\n              double_quoted_string => color('bold bright_green on_black'),\n              single_quoted_string => color('green on_black'),\n              qw_string            => color('bright_yellow on_black'),\n              var_name             => color('bold magenta'),\n              special_var_name     => color('bold magenta'),\n              special_fh           => color('bold cyan'),\n              sub_name             => color('bold white'),\n              sub_proto            => color('bright_green on_black'),\n              bare_word            => color('green'),\n              data                 => color('blue on_black'),\n              pod                  => color('bright_blue on_black'),\n              format               => color('magenta on_black'),\n              v_string             => color('green on_black'),\n             );\n\nmy $code = (\n    do { local $/; <> }\n      // die \"usage: $0 [file]\\n\"\n);\n\nmy $reset_color = color('reset');\n\nperl_tokens {\n    my ($token, $from, $to) = @_;\n    print +(exists($scheme{$token}) ? $scheme{$token} : ''), substr($code, $from, $to - $from), $reset_color;\n}\n$code;\n\n=encoding utf8\n\n=head1 NAME\n\npl2term - highlights Perl code in terminal\n\n=head1 SYNOPSIS\n\n    pl2term < [script.pl]\n\n=head1 DESCRIPTION\n\npl2term reads a Perl script and outputs an highlighted terminal version of it.\n\nI<NOTE:> a compatible terminal is required.\n\n=head1 AUTHOR\n\nDaniel \"Trizen\" Șuteu, E<lt>trizenx@gmail.comE<gt>\n\n=head1 COPYRIGHT AND LICENSE\n\nCopyright (C) 2015\n\nThis library is free software; you can redistribute it and/or modify\nit under the same terms as Perl itself, either Perl version 5.22.0 or,\nat your option, any later version of Perl 5 you may have available.\n\n=cut\n"
  },
  {
    "path": "Visualisators/random_finder_visual.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 13 April 2015\n# Website: https://github.com/trizen\n\n#\n## A recursive-random text finder with potential support for parallelization\n#\n\n# It tries to find a substring inside a given text, starting at random positions, by\n# splitting (recursively) the text into halves, stopping when the window is too narrow.\n# If the substring exists inside the text, it returns \"true\". \"false\" otherwise.\n\n# This is the visual version of the algorithm.\n\nuse 5.016;\nuse strict;\nuse warnings;\n\nuse List::Util qw(shuffle);\nuse Term::ANSIColor qw(colored);\n\nsub rec_find {\n    my ($text, $substr) = @_;\n\n    my $limit = length($substr);\n\n    my $find = sub {\n        my ($min, $max) = @_;\n\n        my $middle = int(($max + $min) / 2);\n        my $pos_l  = int(($middle + $min) / 2);\n        my $pos_r  = int(($middle + $max) / 2);\n\n        if (($middle - $pos_l) > $limit * 2) {\n#<<<\n            __SUB__->(@{$_}) for shuffle(\n                [$pos_l, $middle],\n                [$pos_r,    $max],\n                [$min,    $pos_l],\n                [$middle, $pos_r],\n            );\n#>>>\n        }\n        else {\n            my $t = $text;\n            substr($t, $min, $max - $min,\n                colored(substr($t, $min, $max - $min), 'bold red'));\n            system 'clear';\n            print $t;\n            sleep 1;\n        }\n    };\n\n    my $min = 0;\n    my $max = length($text);\n    $find->($min, $max);\n}\n\nmy $text = do { local $/; <DATA> };\nrec_find($text, 'following blue');\n\n__END__\nThe data structure has one node for every prefix of every\nstring in the dictionary. So if (bca) is in the dictionar\nthen there will be nodes for (bca), (bc), (b), and (). If\nis in the dictionary then it is blue node. Otherwise it i\nThere is a black directed \"child\" arc from each node to a\nis found by appending one character. So there is a black\nThere is a blue directed \"suffix\" arc from each node to t\npossible strict suffix of it in the graph. For example, f\nare (aa) and (a) and (). The longest of these that exists\ngraph is (a). So there is a blue arc from (caa) to (a). T\na green \"dictionary suffix\" arc from each node to the nex\nin the dictionary that can be reached by following blue a\nexample, there is a green arc from (bca) to (a) because (\nnode in the dictionary (i.e. a blue node) that is reached\nthe blue arcs to (ca) and then on to (a).\n"
  },
  {
    "path": "Visualisators/triangle_sub-string_finder.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Trizen\n# License: GPLv3\n# Date: 07 June 2014\n# Website: https://github.com/trizen\n\n# Triangle sub-string finder (concept only)\n# - search a substring using a triangle like pattern,\n#   starting in the middle of the string, continuing\n#   going towards the string edges after each fail-match.\n\nuse 5.014;\nuse strict;\nuse warnings;\n\nuse Term::ANSIColor qw(colored);\n\nsub triangle_finder {\n    my ($s, $c) = @_;\n\n    my $left  = 0;\n    my $right = @{$c};\n\n    my $min = length($s);\n    my $mid = int($left + $right) / 2;\n\n    my $acc = 0;\n    for (my $m1 = $mid - $acc, my $m2 = $mid + $acc ;\n         $m1 > $left && $m2 < $right ;\n         $acc += $min, $m1 = $mid - $acc, $m2 = $mid + $acc) {\n\n        #\n        ## some code here that will perform the search in the left\n        #\n\n        say join('', @{$c}[0 .. $m1 - 1], colored($c->[$m1], 'red'), @{$c}[$m1 + 1 .. $#{$c}]);\n\n        #\n        ## some code here that will perform the search on the right\n        #\n\n        say join('', @{$c}[0 .. $m2 - 1], colored($c->[$m2], 'red'), @{$c}[$m2 + 1 .. $#{$c}]);\n    }\n}\n\nmy @chars = 'a' .. 'z';\ntriangle_finder('i', \\@chars);\n"
  },
  {
    "path": "Visualisators/visual_lz77_compression.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# Date: 14 May 2014\n# License: GPLv3\n# Website: https://github.com/trizen\n\n# A variant of LZ77 compression, with minimum and maximum boundaries control.\n\nuse 5.010;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse open IO => ':utf8', ':std';\nuse Getopt::Long qw(GetOptions);\nuse Term::ANSIColor qw(colored);\n\nmy $min    = 4;\nmy $max    = 32766;\nmy $buffer = 1024;\n\nsub usage {\n    my ($code) = @_;\n    print <<\"USAGE\";\nusage: $0 [options] [files]\n\noptions:\n        --min=i     : minimum length of a dictionary key (default: $min)\n        --max=i     : maximum length of a dictionary key (default: $max)\n        --buffer=i  : buffer size of the input stream, in bytes (default: $buffer)\n        --help      : print this message and exit\n\nexample: $0 --min=4 --max=32 --buffer=512 file.txt\nUSAGE\n    exit($code // 0);\n}\n\nGetOptions(\n           'buffer=i' => \\$buffer,\n           'min=i'    => \\$min,\n           'max=i'    => \\$max,\n           'help'     => \\&usage,\n          )\n  or die(\"Error in command line arguments\\n\");\n\n@ARGV || usage(1);\n\nforeach my $file (@ARGV) {\n    open my $fh, '<', $file;\n    while ((my $size = read($fh, (my $block), $buffer)) > 0) {\n\n        my %dict;\n        $block =~ /(.{$min,$max}?)(?(?=.*?(\\1))(?{$dict{$-[2]}{$-[0]} = length($1)}))(?!)/s;\n\n        my $len = length($block);\n        for (my $i = 0 ; $i < $len ; $i++) {\n            if (exists($dict{$i})) {\n                my ($key) = sort { $dict{$i}{$b} <=> $dict{$i}{$a} } keys %{$dict{$i}};\n                my $vlen = $dict{$i}{$key};\n                print colored(\"[$key,$vlen]\", 'red');                  # this line prints the pointer values\n                print colored(substr($block, $key, $vlen), 'blue');    # this line fetches and prints the real data\n                $i += $vlen - 1;\n            }\n            else {\n                print substr($block, $i, 1);\n            }\n        }\n    }\n    close $fh;\n}\n"
  },
  {
    "path": "Visualisators/visual_sudoku_dice_solver.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 30 June 2013\n# Edit: 30 April 2014\n# Website: https://github.com/trizen\n\n# Sudoku dice game solver\n\nuse 5.010;\nuse strict;\nuse warnings;\n\nuse Time::HiRes qw(sleep);\nuse Term::ANSIColor qw(colored);\nuse List::Util qw(first shuffle);\n\nsub valid_move {\n    my ($row, $col, $table) = @_;\n\n    if (($row < 0 or not exists $table->[$row]) || ($col < 0 or not exists $table->[$row][$col])) {\n        return;\n    }\n\n    return 1;\n}\n\n{\n    my @moves = (\n                 {dir => 'left',  pos => [+0, -1]},\n                 {dir => 'right', pos => [+0, +1]},\n                 {dir => 'up',    pos => [-1, +0]},\n                 {dir => 'down',  pos => [+1, +0]},\n                );\n\n    sub get_moves {\n        my ($table, $row, $col, $number) = @_;\n\n        my @next_pos;\n        foreach my $move (@moves) {\n            if (valid_move($row + $move->{pos}[0], $col + $move->{pos}[1], $table)) {\n                if (    $table->[$row + $move->{pos}[0]][$col + $move->{pos}[1]] != 0\n                    and $table->[$row + $move->{pos}[0]][$col + $move->{pos}[1]] == $number + 1) {\n                    push @next_pos, $move;\n                }\n            }\n        }\n\n        return \\@next_pos;\n    }\n}\n\nmy @steps;\n\nsub init_universe {    # recursion at its best\n    my ($table, $pos) = @_;\n    my ($row,   $col) = @{$pos};\n\n    my $number = $table->[$row][$col];\n    $table->[$row][$col] = 1337;\n\n    print \"\\e[H\\e[J\\e[H\";\n    foreach my $row (@{$table}) {\n        say map {\n                $_ == 1337 ? colored('[ ]', 'bold blue')\n              : $_ == 0    ? colored(' * ', 'bold red')\n              : colored(\" $_ \", 'bold black')\n        } @{$row};\n    }\n    sleep 0.05;\n\n    $table->[$row][$col] = 0;\n\n    if ($number == 0) {\n        pop @steps;\n        return $table;\n    }\n\n    $number = 0 if $number == 3;\n    my $moves = get_moves($table, $row, $col, $number);\n\n    if (@{$moves}) {\n        foreach my $move (@{$moves}) {\n            push @steps, $move;\n\n            my $universe = init_universe([map { [@{$_}] } @{$table}], [$row + $move->{pos}[0], $col + $move->{pos}[1]]);\n\n            if (\n                not first {\n                    first { $_ != 0 } @{$_};\n                }\n                @{$universe}\n              ) {\n                die \"solved\\n\";\n            }\n        }\n\n        return init_universe($table, [$row, $col]);\n    }\n    else {\n        pop @steps;\n        return $table;\n    }\n}\n\n#\n## MAIN\n#\n\n{\n    my @rows = qw(\n      321321313\n      123312222\n      321213131\n      312231123\n      213112321\n      231323123\n      132231231\n      123113322\n      321322113\n      );\n\n    my @table;\n    foreach my $row (@rows) {\n        push @table, [split //, $row];\n    }\n\n    my @positions;\n    foreach my $i (0 .. $#table) {\n        foreach my $j (0 .. $#{$table[$i]}) {\n            if ($table[$i][$j] == 1) {\n                push @positions, [$i, $j];\n            }\n        }\n    }\n\n    foreach my $pos (shuffle @positions) {    # tested solution from position[6]\n\n        eval {\n            init_universe([map { [@{$_}] } @table], $pos);\n        };\n\n        if ($@ eq \"solved\\n\") {\n\n            printf \"** Locate row %d, column %d, click on it and follow the steps:\\n\", ($pos->[0] + 1, $pos->[1] + 1);\n\n            my $i         = 1;\n            my $count     = 1;\n            my $prev_step = (shift @steps)->{dir};\n\n            foreach my $step (@steps) {\n                if ($step->{dir} eq $prev_step) {\n                    ++$count;\n                }\n                else {\n                    printf \"%2d. Go %-8s%s\", $i++, $prev_step, ($count == 1 ? \"\\n\" : \"($count times)\\n\");\n                    $count     = 1;\n                    $prev_step = $step->{dir};\n                }\n            }\n\n            sleep 2;\n            print \"\\n\";\n            @steps = ();\n        }\n    }\n}\n"
  },
  {
    "path": "update_readme.pl",
    "content": "#!/usr/bin/perl\n\n# Author: Daniel \"Trizen\" Șuteu\n# License: GPLv3\n# Date: 24 April 2015\n# Website: https://github.com/trizen\n\n# Updated the README.md file by adding new scripts to the summary.\n\nuse 5.016;\nuse strict;\nuse autodie;\nuse warnings;\n\nuse Cwd                   qw(getcwd);\nuse File::Spec::Functions qw(rel2abs curdir);\nuse File::Basename        qw(basename dirname);\nuse URI::Escape           qw(uri_escape);\n\nmy %ignore;\nif (open my $fh, '<:utf8', '.gitignore') {\n\n    while (<$fh>) {\n        next if /^#/;\n        chomp;\n        if (-e $_) {\n            $ignore{rel2abs($_)} = 1;\n        }\n    }\n\n    close $fh;\n}\n\nsub add_section {\n    my ($section, $file) = @_;\n\n    my ($before, $middle);\n    open my $fh, '<', $file;\n    while (defined(my $line = <$fh>)) {\n        if ($line =~ /^(#+\\h*Summary\\s*)$/) {\n            $middle = \"$1\\n\";\n            last;\n        }\n        else {\n            $before .= $line;\n        }\n    }\n    close $fh;\n\n    open my $out_fh, '>', $file;\n    print {$out_fh} $before . $middle . $section;\n    close $out_fh;\n}\n\nmy $summary_file = 'README.md';\nmy $main_dir     = curdir();\n\n{\n    my @root;\n\n    sub make_section {\n        my ($dir, $spaces) = @_;\n\n        my $cwd = getcwd();\n\n        chdir $dir;\n        my @files = sort { $a->{key} cmp $b->{key} }\n          map { {key => fc(s/\\.\\w+\\z//r), name => $_, path => File::Spec->rel2abs($_)} } glob('*');\n        chdir $cwd;\n\n        my $make_section_url = sub {\n            my ($name) = @_;\n            join('/', basename($main_dir), @root, $name);\n        };\n\n        my $section = '';\n        foreach my $file (@files) {\n            my $title = $file->{name} =~ tr/_/ /r =~ s/ s /'s /gr;\n\n            if ($file->{name} =~ /\\.(\\w{2,3})\\z/) {\n                next if $1 !~ /^(?:p[lm])\\z/i;\n            }\n\n            next if exists $ignore{$file->{path}};\n\n            if (-d $file->{path}) {\n                $section .= (' ' x $spaces) . \"* $title\\n\";\n                push @root, $file->{name};\n                $section .= make_section($file->{path}, $spaces + 4);\n            }\n            else {\n                next if $dir eq $main_dir;\n                my $naked_title = $title =~ s/\\.pl\\z//ri;\n                my $url_path    = uri_escape($make_section_url->($file->{name}), ' ?');\n                $section .= (' ' x $spaces) . \"* [\\u$naked_title]($url_path)\\n\";\n            }\n        }\n\n        pop @root;\n        return $section;\n    }\n}\n\nmy $section         = make_section($main_dir, 0);\nmy $section_content = add_section($section, $summary_file);\n\nsay \"** All done!\";\n"
  }
]